Méthode find avec boucle

**munity** · 16/10/2018, 20h34

bonsoir à tous

j'ai développé une macro grace au phorum sur find et findnext
mais cela ne me donne pas exactement ce que je souhaiterai
en effet j'ai deux tableaux un fichier stock avec code et désignation
et un second ou je n'ai que la désignation
je cherche donc à récupérer le code pour mon second tableau
jusqu'ici tout va bien par contre si j'ai plusieurs désignation identiques, il ne me mets que la première
je me doute qu'il faut certainement ajouté un test ou boucle mais je ne vois pas trop ou
voici mon 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
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
 
 
Sub test()
LePath = ActiveWorkbook.Path & "\"
ClasseurActif = ActiveWorkbook.Name
 
Application.Workbooks.Open LePath & "\ETAT DE STOCKS_AUTOMATE.xls" '
 
    ligne = Cells(Rows.Count, 2).End(xlUp).Row
    Sheets("STOCK").Range("b2:e" & ligne).Copy
    Workbooks(ClasseurActif).Activate
 
    ActiveWorkbook.Worksheets.Add
    ActiveSheet.Name = "stock"
    Range("A1").PasteSpecial (xlPasteValues)
 
    Application.DisplayAlerts = False
    Workbooks("ETAT DE STOCKS_AUTOMATE.xls").Close
    Application.DisplayAlerts = True
 
    Set PlageRech = Sheets("VPC STANDARD").Range("A:A")
    With ThisWorkbook.Worksheets("STOCK")
        i = 2
        While .Cells(i, 2).Value <> ""
            Set c = PlageRech.Find(.Cells(i, 2), LookIn:=xlValues, lookat:=xlWhole)
            If Not c Is Nothing Then
                FirstAddress = c.Address
                Do
                    NUM_PARUTION = .Cells(i, 1)
                    POIDS_PARUTION = .Cells(i, 4)
                    'STOCK
                        Sheets("VPC STANDARD").Range(FirstAddress).Offset(0, 11) = NUM_PARUTION
                        Sheets("VPC STANDARD").Range(FirstAddress).Offset(0, 12) = POIDS_PARUTION
                    Set c = PlageRech.FindNext(c)
                Loop While Not c Is Nothing And c.Address <> FirstAddress
            End If
            i = i + 1
        Wend
    End With
    Set PlageRech = Nothing
End Sub

merci pour vos pistes ou aides

david

**eriiic** · 17/10/2018, 00h40

Bonjour,

je ne vois pas trop le lien avec ton anomalie mais déjà il te manque une , devant LookIn:=
LookIn est le 3ème paramètre, pas le 2nd.
Bizarre que le compilateur ne t'ait rien dit.
eric

Edit : après une nuit de sommeil je vois que j'ai dit une bêtise :-)
Comme tes arguments sont nommés, pas besoin de les placer.

**munity** · 17/10/2018, 00h55

salut eriic

ben je souhaite ajouter chaque code article a chaque fois que necessaire
si designation = livre 1 se trouve sur 10 lignes (contigues ou non) alors recopie 10 fois du code article

merci de ton conseil mais effectivement pas de problème particulier à priori
j'ai réussi en modifiant le code je pense....

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


Sub test()
LePath = ActiveWorkbook.Path & "\"
ClasseurActif = ActiveWorkbook.Name

Application.Workbooks.Open LePath & "\ETAT DE STOCKS_AUTOMATE.xls" '

With Sheets("STOCK")
    ligne = .Cells(Rows.Count, 3).End(xlUp).Row
    .Range("b2:e" & ligne).Copy
End With
    Workbooks(ClasseurActif).Activate
    
    ActiveWorkbook.Worksheets.Add
    ActiveSheet.Name = "STOCK"
    Range("A1").PasteSpecial (xlPasteValues)
        
    Application.DisplayAlerts = False
    Workbooks("ETAT DE STOCKS_AUTOMATE.xls").Close
    Application.DisplayAlerts = True
    
    Sheets("VPC STANDARD").Activate
    
        With Sheets("STOCK")
            For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
                Set PlageRech = Sheets("VPC STANDARD").Range("A:A")
                Set c = PlageRech.Find(.Cells(i, 2), lookat:=xlWhole)
                If Not c Is Nothing Then
                    FirstAddress = c.Address
                    Do
                        NUM_PARUTION = .Cells(i, 1)
                        POIDS_PARUTION = .Cells(i, 4)
                        ligne = Sheets("VPC STANDARD").Range("A" & .Rows.Count).End(xlUp).Row
                            For x = 2 To ligne
                               If Cells(x, 1) = c Then
                                        Sheets("VPC STANDARD").Cells(x, 12) = NUM_PARUTION
                                        Sheets("VPC STANDARD").Cells(x, 13) = POIDS_PARUTION
                                End If
                                
                            Next x
                        Set c = PlageRech.FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> FirstAddress
                End If
            Next i
        End With
        
    Set PlageRech = Nothing
    
End Sub

en rouge le code modifié qui me donne le résultat escompté

si d'autres méthodes je suis preneur évidemment

david

**Philippe Tulliez** · 17/10/2018, 07h48

Bonjour,
J'ai écrit une fonction basée sur la méthode Find qui renvoie dans une table toutes les cellules trouvées (objet Range) en fonction de deux paramètres.
Voir cette réponse https://www.developpez.net/forums/d1...et-listobject/

**RyuAutodidacte** · 17/10/2018, 10h44

Bonjour,

Envoyé par munity

en effet j'ai deux tableaux un fichier stock avec code et désignation
et un second ou je n'ai que la désignation
je cherche donc à récupérer le code pour mon second tableau
jusqu'ici tout va bien par contre si j'ai plusieurs désignation identiques, il ne me mets que la première

Dans ton 1er tableau (code/désignation) , y a-t-il des doublons ?
Dans ton 2è tableau les désignations sont elles écrites de manière identique partout ?

**munity** · 17/10/2018, 19h37

Bonjour ryu
Pour repondre a tes questions
Dans le tableau 1 ou je vais chercher mes codes en fonction de la designation il ny a aucun doublons et il ny en aura jamais car cest la liste unique de tous les articles
Et oui les designations ont la meme orthographe

**RyuAutodidacte** · 18/10/2018, 00h10

Re,

une autre façon de faire via une variable tableau et une collection
PS : il se peut qu'il y est une erreur, je l'ai fait en aveugle sans avoir les données à tester voir légèrement modifier si il le faut

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
Sub test()
Dim w_Actif As Workbook, w_Donnees As Workboo, VA, Coll As New Collection, i As Long, Lig As Long
 
    Set w_Actif = ThisWorkbook
 
    Set w_Donnees = Workbooks.Open(w_Actif.Path & "\ETAT DE STOCKS_AUTOMATE.xls")
    With w_Donnees
        With .Sheets("STOCK")
            VA = .Range("B2:E" & .Cells(.Rows.Count, 3).End(xlUp).Row).Value
        End With
        .Close False
    End With
    Set w_Donnees = Nothing
 
On Error Resume Next
    For i = LBound(VA) To UBound(VA)
        If VA(i, 2) > "" Then  'par précaution je ne connais pas les données - VA(i, 2) => désignation
            Coll.Add i, CStr(VA(i, 2)) ' enregistrement dans la collection de la ligne (i) dont l'index est le nom de la désignation -> CStr(VA(i, 2))
            If Err Then Err.Clear ' par précaution je ne connais pas les données
        End If
    Next
 
    With w_Actif
        '.Worksheets.Add:        .ActiveSheet.Name = "STOCK" ' <= Facultatif car utilsation d'une collection et d'un variable tableau
        With .Sheets("VPC STANDARD")
            Application.ScreenUpdating = False
 
                For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
                    Lig = Coll(CStr(.Cells(i, 1))) 'on vérifie que la "désignation" existe dans la collection
                    ' si y a pas d'erreur , on récupère la ligne  (LIig correspondante dans la variable tableau afin de récupérer les valeurs de NUM_PARUTION et POIDS_PARUTION
                    If Err Then
                        Err.Clear
                    Else
                        .Cells(i, 12) = VA(Lig, 1) ' NUM_PARUTION
                        .Cells(i, 13) = VA(Lig, 4) ' POIDS_PARUTION
                    End If
                Next
 
            Application.ScreenUpdating = True
        End With
 
    End With
On Error GoTo 0
    Set w_Actif = Nothing
End Sub

PS perso : Dédicace à Marc-L qui m'a beaucoup appris

**munity** · 18/10/2018, 02h39

Ok merci pour le code
Je vais le tester
En plus il doit etre plus rapide je pense
Je te tiens au courant
Merci encore

**RyuAutodidacte** · 18/10/2018, 12h11

Bonjour,

Pour l'emplacement des données, je l'ai fait par supposition.
En me précisant l'emplacement exact des données (classeurs et feuilles), on pourra ajuster si nécessaire.

**munity** · 18/10/2018, 16h44

salut ryu

je ne sais pas si j'ai bien compris ta question mais bon je me lance
la feuille de destination est VPC STANDARD
et les cellules de destination sont pour
le code dernière colonne +1
poids dernière colonne +2

ha oui j'y pense
il se peut que VPC STANDARD soit en minuscule
ou ne contienne que VPC soit écrit comme VPC Standard

je ne sais pas si c'est gérable peut être avec un array ?

**RyuAutodidacte** · 18/10/2018, 16h47

Re,

Test déjà sur une copie le code afin de vérifier que tout est ok, en vérifiant avant le nom de la feuille pour qu'elle soit identique
Après on voit

Edit : Pour le nom de la feuille en minuscule ou majuscule, je regarderai dès que j'ai un moment …
+ modif texte au-dessus de l'édit

Edit 2 : là j'ai un peu plus de temps

je ne sais pas si j'ai bien compris ta question mais bon je me lance
la feuille de destination est VPC STANDARD
et les cellules de destination sont pour
le code dernière colonne +1
poids dernière colonne +2

Ce que je voulais dire c'est d'après le code que j'ai fait, Est ce que j'avais bien ciblé les désignations dans la variable tableau VA ainsi que sur le classeur de destination ?

ha oui j'y pense
il se peut que VPC STANDARD soit en minuscule
ou ne contienne que VPC soit écrit comme VPC Standard

As tu plusieurs classeurs de destination où tu lanceras ta macro et qui auront un onglet s'appelant "VPC Standard" ou "VPC STANDARD" ??
Car si tu n'as qu'un seul classeur de destination il suffit juste de donner le bon nommage de l'onglet … ?

Edit 3 :
Bon as tester, mais sur ma version d'excel (2016) je n'ai pas eu de problème pour le nom de l'onglet que ce soit en minuscule ou majuscule.
Qu'en est il chez toi ?

As tu testé le code ??

**munity** · 19/10/2018, 15h44

salut ryu

Ce que je voulais dire c'est d'après le code que j'ai fait, Est ce que j'avais bien ciblé les désignations dans la variable tableau VA ainsi que sur le classeur de destination ?

oui c'est tout à fait ca

As tu plusieurs classeurs de destination où tu lanceras ta macro et qui auront un onglet s'appelant "VPC Standard" ou "VPC STANDARD" ??
Car si tu n'as qu'un seul classeur de destination il suffit juste de donner le bon nommage de l'onglet … ?

non pas de problème sur la casse dans le nom

le fonctionnement de la macro est issue d'un fichier .xlam afin que mes collègues puissent utiliser les différentes macros mise en place par mes petits bras musclés

j'ouvre donc le fichier client et je fais quelques contrôles de cohérence puis je lance la macro

je t'explique en gros le fonctionnement de mon traitement
nous recevons de la part d'un client tous les 15 jours un fichier à traiter pour l'envoi de catalogues
pour chaque catalogue, je dois lui indiquer un poids et un code spécifique puis insérer des lignes si multiples (exemple un client veut 2 livres j'insère donc 1 lignes pour faire 2 lignes)
une fois cette première étape réalisée, j'exporte un fichier texte par catalogue (chaque fichier doit passer dans un traitement postal et non je ne peux pas faire un seul fichier avec tous les catalogues

=>NORMES POSTALES

)
et au bout du bout je repasse tous les fichiers créées dans une moulinette access pour les compiler de nouveaux....

jusque maintenant tout allait bien mais comme on a changé d'outil informatique j'en profite pour améliorer les macros et traitement mais surtout mettre aux normes du nouvel outil

ci dessous la macro complète (sans modification avec la tienne)

insertion des lignes si multiples

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
 
 
Sub INSERTION_LIGNES()
 
Dim i%, j%, n%
Dim c As Range, NoCol As Integer 'integer sur 2007
 
   'With Worksheets("Feuil1").Rows(1)
With ActiveSheet.Rows(1)
    Derlig = .Range("A" & .Rows.Count).End(xlUp).Row
        Set c = .Find("QUANTITE")
        If Not c Is Nothing Then
            NoCol = c.Column
            Columns(NoCol).Insert Shift:=xlToRight
            Cells(1, NoCol) = "NB EXEMPLAIRE"
            DoEvents
        End If
End With
 
With ActiveSheet
        DerCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
        n = .Cells(.Rows.Count, DerCol).End(xlUp).Row
        Application.ScreenUpdating = True
        Range(Cells(2, DerCol - 1), Cells(n, DerCol - 1)) = 1
        For i = n To 1 Step -1
            If IsNumeric(.Cells(i, DerCol)) Then
                j = .Cells(i, DerCol) - 1
                If j > 0 Then
                    .Range(.Cells(i, 1), .Cells(i, DerCol)).Copy
                    .Range(.Cells(i + 1, 1), .Cells(i + j, DerCol)).Insert xlShiftDown
                End If
            End If
        Next i
    End With
    Application.CutCopyMode = False
 
End Sub

rechercher code et poids puis export des fichiers

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
 
 
Sub TRAITEMENT_PROPUBLIC_FDP_FDC()
Application.DisplayAlerts = True
Dim Cel As Range, plg As Range
Dim Derlig As Long
Dim Sh As Worksheet
Dim LePath As String
 
Application.ScreenUpdating = False
 
INSERTION_LIGNES
 
LePath = "\\172.16.0.210\ResolutionS\Mailing\2018\Mise Sous Pli\Press Maker\"
ClasseurActif = ActiveWorkbook.Name
RépertoireActif = ActiveWorkbook.Path & "\"
Application.Workbooks.Open LePath & "\ETAT DE STOCKS_AUTOMATE.xls" '
 
With Sheets("STOCK")
    ligne = .Cells(Rows.Count, 3).End(xlUp).Row
    .Range("b2:e" & ligne).Copy
End With
    Workbooks(ClasseurActif).Activate
 
    ActiveWorkbook.Worksheets.add
    ActiveSheet.Name = "STOCK"
    Range("A1").PasteSpecial (xlPasteValues)
 
    Application.DisplayAlerts = False
    Workbooks("ETAT DE STOCKS_AUTOMATE.xls").Close
    Application.DisplayAlerts = True
 
    Sheets("VPC STANDARD").Activate
        With Sheets("STOCK")
            For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
                Set PlageRech = Sheets("VPC STANDARD").Range("A:A")
                Set c = PlageRech.Find(.Cells(i, 2), lookat:=xlWhole)
                If Not c Is Nothing Then
                    FirstAddress = c.Address
                    Do
                        NUM_PARUTION = .Cells(i, 1)
                        POIDS_PARUTION = .Cells(i, 4)
                        ligne = Sheets("VPC STANDARD").Range("A" & .Rows.Count).End(xlUp).Row
                        Col = Sheets("VPC STANDARD").Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
                            For x = 2 To ligne
                               If Cells(x, 1) = c Then
                                        Sheets("VPC STANDARD").Cells(x, Col + 1) = NUM_PARUTION
                                        Sheets("VPC STANDARD").Cells(x, Col + 2) = POIDS_PARUTION
                                End If
 
                            Next x
                        Set c = PlageRech.FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> FirstAddress
                End If
            Next i
        End With
 
    Set PlageRech = Nothing
 
    With Sheets("VPC STANDARD")
        .Cells(1, Col + 1) = "CODE DESIGNATION"
        .Cells(1, Col + 2) = "POIDS PARUTION"
    End With
 
Application.DisplayAlerts = False
    Sheets("STOCK").Delete
Application.DisplayAlerts = True
 
Application.ScreenUpdating = False
With Sheets(2)
    Derlig = .Range("A" & .Rows.Count).End(xlUp).Row
    DerCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
        For j = 2 To Derlig
            .Cells(j, 1).Value = Application.Proper(SupprimerAccents(.Cells(j, 1)))
            .Cells(j, 1).Value = Application.WorksheetFunction.Trim(.Cells(j, 1))
            With Application
                .Cells(j, 1).Value = .Clean(.Cells(j, 1).Value)
            End With
        Next
    Set plg = .Range(.Cells(1, 1), .Cells(Derlig, DerCol))
    plg(1).Resize(Derlig).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("Z1"), Unique:=True
    For Each Cel In .Range("Z2:Z" & .Cells(Rows.Count, "Z").End(xlUp).Row)
        If Cel <> "" Then
            .[Z2] = Cel.Value
            Set Sh = Sheets.add
            plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("Z1:Z2"), CopyToRange:=Sh.Range("A1")
            Sh.Columns.EntireColumn.AutoFit
            Sh.Move
            ActiveWorkbook.SaveAs Filename:=RépertoireActif & "\" & Cel.Value & ".xls", FileFormat:=xlExcel8
            ActiveWorkbook.Close
        End If
    Next Cel
    .Columns("Z:Z").Clear
End With
Application.ScreenUpdating = True
 
End Sub

je dois encore améliorer le processus a savoir
si colonne quantité non trouvé message d'alerte et arrêt du traitement pour correction
ajout de la colonne pays si absente

mais bon cela relève du petit bonus c'est tout à fait faisable à la main....

david

**RyuAutodidacte** · 19/10/2018, 15h57

Salut,

je dois encore améliorer le processus a savoir
si colonne quantité non trouvé message d'alerte et arrêt du traitement pour correction
ajout de la colonne pays si absente

Passe par un Array pour la vérification en début de macro pour vérifier et corriger le tir le cas échéant,
comme cela pas besoin d'arrêter la macro pour le reste du processus qui suit

**munity** · 20/11/2018, 15h02

desolé de cette réponse tardive
merci pour tes précieux conseils RyuAutodidacte

Méthode find avec boucle

Macros et VBA Excel

Discussions similaires

Partager

Partager