Discussion :

[nunnu27]

Bonsoir,

Tout est dans la question.
Comment mettre plusieurs arguments dans cette expression:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If .Range("I" & f).Value <> 0 Then

Du style:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If .Range("I","F" & f).Value <> 0 Then

ou encore:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If .Range("I" & f, "F" & f).Value <> 0 Then

ou bien d'autres a vrai dire...mais sans résultat.

J'ouvre ce topic juste pour cela (et laisse ouvert l'ancien)car après plusieurs tentative cela me génère toujours une erreur...

Merci d'avance pour votre aide.

Cordialement

[mercatog]

Suite à ton précédent post, on aura à faire à

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
Dim i As Byte
With Sheets("1 à 25")
    For i = 10 To 59
        On Error Resume Next
        If .Range("F" & i).Value + .Range("I" & i).Value + .Range("L" & i).Value + .Range("O" & i).Value + .Range("R" & i).Value <> 0 Then Sheets("resume").Cells(Rows.Count, 1).End(xlUp)(2).Value = IIf(i Mod 2 = 0, .Range("A" & i).Value, .Range("A" & i - 1).Value)
        On Error GoTo 0
    Next i
End With

Edit: + à la place de *
si tu as toujours des valeurs >=0
sinon le test sera

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If .Range("F" & i).Value <> 0 Or .Range("I" & i).Value <> 0 Or .Range("L" & i).Value <> 0 Or .Range("O" & i).Value <> 0 Or .Range("R" & i).Value <> 0

[nunnu27]

Bonsoir Mercatog,

(Tout d'abord merci d'etre une fois de plus là...)

En fait, ce n'est pas tout a fais ça...

Clairement (je m'excuse d'avance si je n'ai pas été clair la premiere fois...):

Si "F10"<>0 alors je copie la valeur de "A10" dans la cellule "A1" de la new feuil, et je copie la valeur de "D10"(cellule 2 fois a gauche) dans la cellule "C1" de la new feuil.
J'ai trouvé comment faire cela.
code:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Dim f As Byte
With Sheets("1 à 25")
   For f = 10 To 59
        If .Range("F" & f).Value <> 0 Then Sheets("resume").Cells(Rows.Count, 1).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("A" & f).Value, .Range("A" & f - 1).Value): Sheets("resume").Cells(Rows.Count, 3).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("D" & f).Value, .Range("D" & f).Value)
    Next f
End With

n.b: je ne peux pas faire un "With .Range("F" & f).Value <> 0" car cela genere une reeur du type "Next sans For"...bizarre.

Là où ça se corse, c'est pour lui dire "et/ou" c-a-d dans le cas où plusieurs cellules de la ligne 10 sont différentes de 0 (comme "F10" et "I10" par exemple).

j'ai donc ceci:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
With Sheets("1 à 25")
    For f = 10 To 59
        If .Range("F" & f).Value <> 0 Then Sheets("resume").Cells(Rows.Count, 1).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("A" & f).Value, .Range("A" & f - 1).Value): Sheets("resume").Cells(Rows.Count, 3).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("D" & f).Value, .Range("D" & f).Value)
    Next f
 
    For f = 10 To 59
        If .Range("I" & f).Value <> 0 Then Sheets("resume").Cells(Rows.Count, 5).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("G" & f).Value, .Range("G" & f).Value)
    Next f
End With

Mais cela ne fonctionne correctement que si les 2 cellules sont differentes de zero car si seule la cellule "I10"<>0 alors je ne copie/colle que la valeur de la cellule "2 fois a gauche sans celle de "A10".

Merci d'avance encore une fois.

n.b:je mets comme résolu l'ancien post.

[mercatog]

peut être ceci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
With Sheets("1 à 25")
    For f = 10 To 59
        If .Range("F" & f).Value <> 0 Then
            Sheets("resume").Cells(Rows.Count, 1).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("A" & f).Value, .Range("A" & f - 1).Value)
            Sheets("resume").Cells(Rows.Count, 3).End(xlUp)(2).Value = .Range("D" & f).Value
        ElseIf .Range("I" & f).Value <> 0 Then
            Sheets("resume").Cells(Rows.Count, 5).End(xlUp)(2).Value = .Range("G" & f).Value
        End If
    Next f
End With

[nunnu27]

Re,

En effet, je n'ai plus l'erreur "Next sans For" donc c'est moi qui devait faire une mauvaise manip...

Le pb est que cela fonctionne dans le cas où juste "F10"<>O.
Si juste "I10"<>O alors cela ne copie pas la "A10" en "A1".

De plus, il faut enlever le "-1" a la fin dans le cas où c'est "F11"<>O.

J'ai donc ceci:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
With Sheets("1 à 25")
    For f = 10 To 59
        If .Range("F" & f).Value <> 0 Then
            Sheets("resume").Cells(Rows.Count, 1).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("A" & f).Value, .Range("A" & f - 1).Value)
            Sheets("resume").Cells(Rows.Count, 3).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("D" & f).Value, .Range("D" & f).Value)
        ElseIf .Range("I" & f).Value <> 0 Then
            Sheets("resume").Cells(Rows.Count, 1).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("A" & f).Value, .Range("A" & f - 1).Value)
            Sheets("resume").Cells(Rows.Count, 5).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("G" & f).Value, .Range("G" & f).Value)
        End If
    Next f
End With

Cela fonctionne mais seulement dans le cas ou j'ai juste "I10"(ou "I11" ou "F10" ou "F11")<>0.
Lorsque j'ai les deux cellules <>O (c-a-d "F10" et "I10" par exemple) alors il ne copie que la valeur de "A10" et "D10", il manque donc la valeur de "G10"...

Je sais que c'est un peu tordu....

Clairement:exemple
si sur feuil(1 à 25):
A10 / F10 / I10 / L10 / O10 / R10
1 / <>0 / <>0 / =0 / <>0 / =0

alors sur l'autre feuil(resume):
A1 / C1 / E1 / G1 / H1 / J1
1 / "D10".Val/ "G10".Val/ " " / "M10".Val / " "

Les slash represente les separations.

Je pense que cet exemple est plus clair que tout les discours que j'ai eu depuis le début.

C'est pour montrer que plusieurs cas sont possible.

J'espere avoir été plus clair et donc moins confus dans l'objectif de mon code...

Merci d'avance pour tes commentaires.

Cordialement

[mercatog]

Explications incompréhensibles désolé

fais un fichier test avec les données initiales et le résultat souhaité

ce fichier devra comporter TOUS les cas de figures

[nunnu27]

Re,

Voici en fichier joint un exemple concret.

J'espère que ceci sera plus clair.

Encore une fois merci de te torturer l'esprit pour me sortir de cette situation compliqué.

Ceci est un exemple avec 2 feuil (1 à 25 et 26 à 50).
Mais cela peut monter jusqu'à 4 feuilles (c-a-d 76 à 100).

Ci-joint un fichier .xls montrant un cas de figure (une seule feuil "1 à 25" + la feuil "resume" qui sera généré lors de la sauvegarde du fichier).
Merci encore...

Cordialement

[nunnu27]

Re,

Après essais, j'ai ce code:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
With Sheets("1 à 25")
    For f = 10 To 59
        If .Range("F" & f).Value <> 0 Then
            Sheets("resume").Cells(Rows.Count, 1).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("A" & f).Value, .Range("A" & f - 1).Value)
            Sheets("resume").Cells(Rows.Count, 3).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("D" & f).Value, .Range("D" & f).Value)
        ElseIf .Range("I" & f).Value <> 0 Then
            Sheets("resume").Cells(Rows.Count, 1).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("A" & f).Value, .Range("A" & f - 1).Value)
            Sheets("resume").Cells(Rows.Count, 5).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("G" & f).Value, .Range("G" & f).Value)
        ElseIf .Range("L" & f).Value <> 0 Then
            Sheets("resume").Cells(Rows.Count, 1).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("A" & f).Value, .Range("A" & f - 1).Value)
            Sheets("resume").Cells(Rows.Count, 5).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("J" & f).Value, .Range("J" & f).Value)
        ElseIf .Range("O" & f).Value <> 0 Then
            Sheets("resume").Cells(Rows.Count, 1).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("A" & f).Value, .Range("A" & f - 1).Value)
            Sheets("resume").Cells(Rows.Count, 5).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("M" & f).Value, .Range("M" & f).Value)
        ElseIf .Range("R" & f).Value <> 0 Then
            Sheets("resume").Cells(Rows.Count, 1).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("A" & f).Value, .Range("A" & f - 1).Value)
            Sheets("resume").Cells(Rows.Count, 5).End(xlUp)(2).Value = IIf(f Mod 2 = 0, .Range("P" & f).Value, .Range("P" & f).Value)
 
        End If
    Next f
End With

Il fonctionne presque parfaitement.
Cependant, lors de plusieurs cellules (sur une même ligne) <>0, seule la premiere cellule (la plus a gauche)<>0 est notée dans la seconde feuille(resume).

J'avoue que là je seche....

Si vous avez une idée, je suis preneur...

Cordialement

[mercatog]

l'explication pour plus tard

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Dim i As Byte, j As Byte
Dim sht As Worksheet
Dim NewLig As Long
 
Set sht = Sheets("resume")
With Sheets("1 à 25")
    For i = 10 To 59
        If .Range("F" & i) & .Range("I" & i) & .Range("L" & i) & .Range("O" & i) & .Range("R" & i) <> "00000" Then
            NewLig = sht.Cells(Rows.Count, 1).End(xlUp).Row + 1
            sht.Range("A" & NewLig).Value = IIf(i Mod 2 = 0, .Range("A" & i).Value, .Range("A" & i - 1).Value)
            For j = 6 To 18 Step 3
                If .Cells(i, j) <> 0 Then sht.Cells(NewLig, Int(2 * j / 3 - 1)) = .Cells(i, j - 2)
            Next j
        End If
    Next i
End With
Set sht = Nothing

[nunnu27]

Re,

Je viens de tester le code, et il fonctionne parfaitement pour tous les cas que j'ai testé.... conclusion: !!!

Par contre, il est clair que ce n'est plus dans mes compétences...il va me falloir des heures pour le comprendre (ou du moins quelques explications+des heures de comprehension..).

Évidement: Un très grand merci a toi pour le temps que tu a dû passer pour le générer...surtout à cette heure-ci.


Bref, heureusement que tu est là (une fois de plus).Je commençais à être en rupture a me torturer l'esprit dans tous les sens...
Il ne me reste plus qu'à le modifier pour qu'il fonctionne avec les autres feuilles le cas échéant...

Sur ce, bonne soirée et merci encore (m'en vais l'intégrer dans ma fonction "SAVE").

Amicalement

Manu

[mercatog]

Ci joint explication (avec commentaires)
j'ai fais un petit changement de variable

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Dim sht As Worksheet
Dim NewLig As Long
Dim i As Byte, j As Byte
 
Set sht = Sheets("resume")                  'On instancie le feuille resume dans la variable sht
With Sheets("1 à 25")
    For i = 10 To 59
        'Si la concatenation des 5 champs <>"00000", c'est à dire, il existe au moins une cellule <>0 dans la ligne i
        If .Range("F" & i) & .Range("I" & i) & .Range("L" & i) & .Range("O" & i) & .Range("R" & i) <> "00000" Then
            'NewLig est la ligne de la première cellule vide de la colonne A de la feuille resume
            NewLig = sht.Cells(Rows.Count, 1).End(xlUp).Row + 1
            'Dans cette cellule on copie la valeur correspondante (du fait de la fusion, on prends soit Ai soit Ai-1)
            sht.Range("A" & NewLig).Value = IIf(i Mod 2 = 0, .Range("A" & i).Value, .Range("A" & i - 1).Value)
            'On parcours les colonnes 6, 9, 12, 15 et 18 (F, I, L, O et R) de la ligne i
            For j = 2 To 6
                'Si la cellule <>0 on transfert la valeur de la cellule offset(0, -2) dans la cellule approprié de la feuille resume
                If .Cells(i, 3 * j) <> 0 Then sht.Cells(NewLig, 2 * j - 1) = .Cells(i, 3 * j - 2)
            Next j
        End If
    Next i
End With
Set sht = Nothing                           'On libère la variable sht

[nunnu27]

Bonsoir (toujours pas couché..??.,

Merci pour le fichier avec commentaire.

Je vais regarder ça demain matin car là je commence à fatiguer dur(je vais rien comprendre ou peu du moins)...et ça risque d'etre difficile au reveil...

Pour infos, j'ai quasiment finalisé le code (grace a tes interventions / pas très compliqué vu que tu m'a mâché tout le boulot...)(integré dans ma fonction"SAVE").

Ci-joint le code (je te soulage de la mise en page de ma feuil"resume" car c'est costaud (j'ai utilisé le generateur de macro temporairement donc beaucoup de ligne inutiles "+ de 100...):

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
Sub Save_control()
 
'-----------------------genere la feuille "resume" + mise en page------
 
Dim shresume As Worksheet
 
    Set shresume = Sheets.Add(After:=Sheets(Sheets.Count))
    shresume.Name = "resume"
    Set shresume = Nothing
 
'-----------------------genere le resumer--------
Dim i As Byte, j As Byte
Dim sht As Worksheet
Dim NewLig As Long
 
Set sht = Sheets("resume")
With Sheets("1 à 25")
    For i = 10 To 59
        If .Range("F" & i) & .Range("I" & i) & .Range("L" & i) & .Range("O" & i) & .Range("R" & i) <> "00000" Then
            NewLig = sht.Cells(Rows.Count, 1).End(xlUp).Row + 1
            sht.Range("A" & NewLig).Value = IIf(i Mod 2 = 0, .Range("A" & i).Value, .Range("A" & i - 1).Value)
            For j = 6 To 18 Step 3
                If .Cells(i, j) <> 0 Then sht.Cells(NewLig, Int(2 * j / 3 - 1)) = .Cells(i, j - 2)
            Next j
        End If
    Next i
End With
Set sht = Nothing
'-----------------
On Error GoTo Fin_de_procedure
 
Dim k As Byte, l As Byte
Dim sht26 As Worksheet
Dim NewLig26 As Long
 
Set sht26 = Sheets("resume")
With Sheets("26 à 50")
    For k = 10 To 59
        If .Range("F" & k) & .Range("I" & k) & .Range("L" & k) & .Range("O" & k) & .Range("R" & k) <> "00000" Then
            NewLig26 = sht26.Cells(Rows.Count, 1).End(xlUp).Row + 1
            sht26.Range("A" & NewLig26).Value = IIf(k Mod 2 = 0, .Range("A" & k).Value, .Range("A" & k - 1).Value)
            For l = 6 To 18 Step 3
                If .Cells(k, l) <> 0 Then sht26.Cells(NewLig26, Int(2 * l / 3 - 1)) = .Cells(k, l - 2)
            Next l
        End If
    Next k
End With
Set sht26 = Nothing
'-----------------
On Error GoTo Fin_de_procedure
 
Dim m As Byte, n As Byte
Dim sht51 As Worksheet
Dim NewLig51 As Long
 
Set sht51 = Sheets("resume")
With Sheets("51 à 75")
    For m = 10 To 59
        If .Range("F" & m) & .Range("I" & m) & .Range("L" & m) & .Range("O" & m) & .Range("R" & m) <> "00000" Then
           NewLig51 = sht51.Cells(Rows.Count, 1).End(xlUp).Row + 1
           sht51.Range("A" & NewLig51).Value = IIf(m Mod 2 = 0, .Range("A" & m).Value, .Range("A" & m - 1).Value)
            For n = 6 To 18 Step 3
               If .Cells(m, n) <> 0 Then sht51.Cells(NewLig51, Int(2 * n / 3 - 1)) = .Cells(m, n - 2)
            Next n
       End If
    Next m
End With
Set sht51 = Nothing
'----------------
On Error GoTo Fin_de_procedure
 
Dim O As Byte, P As Byte
Dim sht76 As Worksheet
Dim NewLig76 As Long
 
Set sht76 = Sheets("resume")
With Sheets("76 à 100")
    For O = 10 To 59
        If .Range("F" & O) & .Range("I" & O) & .Range("L" & O) & .Range("O" & O) & .Range("R" & O) <> "00000" Then
            NewLig76 = sht76.Cells(Rows.Count, 1).End(xlUp).Row + 1
            sht76.Range("A" & NewLig76).Value = IIf(O Mod 2 = 0, .Range("A" & O).Value, .Range("A" & O - 1).Value)
            For P = 6 To 18 Step 3
                If .Cells(O, P) <> 0 Then sht76.Cells(NewLig76, Int(2 * P / 3 - 1)) = .Cells(O, P - 2)
            Next P
        End If
    Next O
End With
Set sht76 = Nothing
 
Fin_de_procedure:
 
'--------------------------copie le fichier--------------
                    'defini et fixe l'adresse de sauvegarde
                    'le nom de sauvegarde depend de la valeur des cellules remplis a l'ouverture du fichier
   Dim strExtractName As String 'creation d'une variable pour appliquer
    strExtractName = "C:\Users\studio16\Desktop\Controle\Controle_Preliminaire\Controles\" & "Controle_Preliminaire" & "_" & [B3].Value & "_" & [C6].Value & [D6].Value & "_" & [J7].Value & ".xlsm"
    ActiveWorkbook.SaveAs Filename:=strExtractName
 
End Sub

Bon, je conçois que le code est pas très propre, mais avec les commentaires je comprends bien.

Bref, une fois de plus, merci a toi pour le temps passé à m'expliquer et m'aider (temps que tu aurais pu passer a faire autre chose....).

Sur ce, je te souhaite une bonne nuit et surtout un bon courage pour demain!...

Amicalement

Manu

[mercatog]

Bonsoir (toujours pas couché..??

décalage horaire GMT!
Sinon, pourquoi de tels gâchis?
Les feuilles se ressemblent (peut être), on fait une simple boucle (pas testé)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
Sub Save_control()
Dim i As Byte, j As Byte, k As Byte
Dim sht As Worksheet
Dim strExtractName As String
Dim NewLig As Long
Dim TabSht
 
Application.ScreenUpdating = False
TabSht = Array("1 à 25", "26 à 50", "51 à 75", "76 à 100")
 
'-----------------------génère la feuille "resume" + mise en page------
'Ici, si la feuille resume existe déjà, on la supprime et on crée une nouvelle vierge
On Error Resume Next
Set sht = Sheets("resume")
On Error GoTo 0
If Not sht Is Nothing Then
    Application.DisplayAlerts = False
    sht.Delete
    Application.DisplayAlerts = False
End If
Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
sht.Name = "resume"
'>>>>> mise en page, mets là en procédure séparée que tu appelle par son nom ici
'-----------------------génère le resumer--------
 
For k = LBound(TabSht) To UBound(TabSht)
    With Sheets(TabSht(k))
        For i = 10 To 59
            If .Range("F" & i) & .Range("I" & i) & .Range("L" & i) & .Range("O" & i) & .Range("R" & i) <> "00000" Then
                NewLig = sht.Cells(Rows.Count, 1).End(xlUp).Row + 1
                sht.Range("A" & NewLig).Value = IIf(i Mod 2 = 0, .Range("A" & i).Value, .Range("A" & i - 1).Value)
                For j = 2 To 6
                    If .Cells(i, 3 * j) <> 0 Then sht.Cells(NewLig, 2 * j - 1) = .Cells(i, 3 * j - 2)
                Next j
            End If
        Next i
    End With
Next k
Set sht = Nothing
'--------------------------copie le fichier--------------
'ici à vérifier par rapport à la feuille active
strExtractName = "C:\Users\studio16\Desktop\Controle\Controle_Preliminaire\Controles\" & "Controle_Preliminaire" & "_" & [B3].Value & "_" & [C6].Value & [D6].Value & "_" & [J7].Value & ".xlsm"
ThisWorkbook.SaveAs Filename:=strExtractName
End Sub

[nunnu27]

Bonjour (ou bonsoir du coup ).

En effet, je n'ai pas beaucoup chercher (a vrai dire:juste des copier/coller avec changement de variable...c'était la méthode la plus "sûr" pour moi.).

Sinon, je vais tester les 2 codes voir comment ils réagissent.
Surtout le dernier car il est quand même plus "propre" que mon "vulgaire" copier/copier tout moche (mais fonctionnel ).

Je te tiens au courant dans le week-end (car il faut que je finisse du boulot avant...).

Bon courage et merci encore pour ton aide.

Amicalement

Manu

n.b: je ne clôture pas ce topic car il reste a tester les derniers code.