Faire appel à un autre classeur et supprimer les doublons sous conditions

**RyuAutodidacte** · 10/01/2017, 10h34

Après tests les données me semblait tomber correctement (mais c'était tard le soir)
Je n'ai pas encore mis la gestion si lignes vide et la possibilité de supprimer des lignes vides si cela doit arriver … ??

**nananinanana** · 10/01/2017, 10h58

Lorsque je rajoute une ligne en fin de feuille avec un document existant et une nouvelle révision dans ma feuille d'origine, il repasse à la dernière ligne dans ma feuille de destination (donc n'a plus les bons paramètres associés)

Erreur 9 (l'indice n'appartient pas à la section) quand le tableau change de dimension

Edit : j'ai l'impression que le repassage à la ligne se faire juste pour le premier document.. Je vais continuer de tester

**RyuAutodidacte** · 10/01/2017, 11h31

J'ai pas eu ce cas là, mais je re-testerais des que je peux.

Normalement ca ne devrait pas…

Le principe on prend dans destination avec un tableau les docs et un autres les révisions
Puis dans un seul tableau les docs et révisions de la feuille origine
On insére alors d'abord les données des 2 tableaux doc et rev de destination dans la collection
et on insère ensuite les données du tableau venant de origine dans la collection,
la gestion de doublons se faisant en même temps

Une fois la collection rempli par les tableaux (sans doublons), on remets docs et révisions dans leur colonnes respectives (d'où l'utilisation de 2 tableaux dans destination qui servent en entrée et sortie)

Edit : je viens de voir une erreur dans mon code ou j'ai oublié des guillemets pour la feuille "GMD"
Désolé

**nananinanana** · 10/01/2017, 12h25

Itm variable non définie ? ça ne me faisait pas ça il y a 5min

**RyuAutodidacte** · 10/01/2017, 12h33

Mettre à la fin des déclarations de variable comme ceci (voir la ligne de oce correspondante):

Code :

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

Dim S_Doc(), S_Rev, DerL&, D_Doc(), D_Rev(), Coll As New Collection, i&, Itm$

**nananinanana** · 10/01/2017, 12h39

Edit : je ne comprends pas mais ça ne fonctionne plus

**RyuAutodidacte** · 10/01/2017, 12h52

je suis en train de re tester car il vrai que le soir avec la fatigue je puisse faire des erreurs (en général j'essaie d'éviter de les faire mais là

dsl)
j'en ai trouvé une autre, je regarde si je trouve autre chose et je remet le code

Edit : c'est quoi qui ne marche plus ?? message d'erreur ??

je remets le code entier (je l'ai commencé sur PC) là je suis sur Mac pas de PC à dispo mais ça ne devrait pas poser de problème

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
Sub COPIEDONNEES()
Dim S_Doc(), S_Rev, DerL&, D_Doc(), D_Rev(), Coll As New Collection, i&, Itm$, Cle$
 
   'NomFichierEntree = Application.GetOpenFilename("Fichier Excel (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm")
 
   'If NomFichierEntree <> False Then
 
       'Workbooks.Open NomFichierEntree
       'Fichier = Right(NomFichierEntree, Len(NomFichierEntree) - InStrRev(NomFichierEntree, "\"))
 
       With ThisWorkbook ' Workbooks(Fichier)
           DerL = .Sheets("Feuille Origine").Cells(Rows.Count, 1).End(xlUp).Row
           S_Doc = .Sheets("Feuille Origine").Range("A9:F" & DerL).Value
           '.Close False
       End With
 
       For i = 1 To UBound(S_Doc)
           S_Doc(i, 1) = S_Doc(i, 1) & S_Doc(i, 2) & S_Doc(i, 3) & S_Doc(i, 4) & S_Doc(i, 5)
           S_Doc(i, 2) = S_Doc(i, 6)
       Next
 
       ReDim Preserve S_Doc(1 To UBound(S_Doc), 1 To 2)
 
        DerL = Sheets("GMD").Cells(Rows.Count, 2).End(xlUp).Row
 
                On Error Resume Next
 
        If DerL > 5 Then
            D_Doc = Sheets("GMD").Range("B6:B" & DerL).Value: D_Rev = Sheets("GMD").Range("D6:D" & DerL).Value
 
            For i = LBound(D_Doc) To UBound(D_Doc)
                Itm = D_Doc(i, 1) & "_" & D_Rev(i, 1): Cle = CStr(D_Doc(i, 1))
                Coll.Add Itm, Cle
                If Err.Number = 457 Then
                    If D_Rev(i, 1) > Split(Coll(D_Doc(i, 1)), "_")(1) Then
                        L = IndexColl(Coll, D_Doc(i, 1)): Coll.Remove L
                        If Coll.Count = 0 Then Coll.Add Itm, Cle Else If L = 1 Then Coll.Add Itm, Cle, L Else Coll.Add Itm, Cle, , L - 1
                    End If
                    Err.Clear
                End If
            Next
        End If
 
        For i = LBound(S_Doc) To UBound(S_Doc)
            Itm = S_Doc(i, 1) & "_" & S_Doc(i, 2): Cle = CStr(S_Doc(i, 1)):
            Coll.Add Itm, Cle
            If Err.Number = 457 Then
                If S_Doc(i, 2) > Split(Coll(S_Doc(i, 1)), "_")(1) Then
                    L = IndexColl(Coll, S_Doc(i, 1)): Coll.Remove L
                    If Coll.Count = 0 Then Coll.Add Itm, Cle Else If L = 1 Then Coll.Add Itm, Cle, L Else Coll.Add Itm, Cle, , L - 1
                End If
                Err.Clear
            End If
        Next
 
            On Error GoTo 0
 
        ReDim D_Doc(1 To Coll.Count, 1 To 1): ReDim D_Rev(1 To Coll.Count, 1 To 1)
        For i = 1 To Coll.Count
            D_Doc(i, 1) = Split(Coll(i), "_")(0): D_Rev(i, 1) = Split(Coll(i), "_")(1)
        Next
 
        Set Coll = Nothing
 
            Application.ScreenUpdating = False
 
        Sheets("GMD").Range("B6").Resize(UBound(D_Doc), UBound(D_Doc, 2)) = D_Doc
        Sheets("GMD").Range("D6").Resize(UBound(D_Rev), UBound(D_Rev, 2)) = D_Rev
 
            Application.ScreenUpdating = True
 
    'End If
 
End Sub
 
 
Function IndexColl(Macoll As Collection, ByVal V As String) As Long
    For i = 1 To Macoll.Count
        If Macoll(i) = Macoll(V) Then
            IndexColl = i: Exit Function
        End If
    Next
End Function

Edit : J'ai re testé plusieurs fois et la ca me semble correct … qu'en est il de votre coté ??

Est il possible de rencontré des lignes vides entre les docs dans la feuille de destination ??
Dans la feuille origine dans le cas ou l'une (ou plusieurs) des 5 colonnes n'est pas remplie, que se passe t-il ?? car cela fausses le nom d'un doc à la concaténation si cela arrive

**nananinanana** · 10/01/2017, 13h43

J'ai compris le soucis,

initialement j'avais une autre macro que j'ai souhaité rajouter ce qui crée les messages d'erreur

Celle ci-dessous

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
 
Option Explicit
Dim Continuer As Integer, MaLigne As Long
Dim ValCell As Variant
Dim DerL&
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
DerL = Sheets("GMD").Cells(Rows.Count, 2).End(xlUp).Row
 
If Not Application.Intersect(Target, Range("D6" & DerL)) Is Nothing Then
Application.EnableEvents = False
Target = UCase(Target)
Application.EnableEvents = True
Worksheets("Modifications").Unprotect (123)
Application.EnableEvents = False
    With Worksheets("Modifications")
        ' calcul de la première ligne vide sur les 8 colonnes
        MaLigne = .UsedRange.Resize(, 7).Find("*", , , , xlRows, xlPrevious).Row + 1
  .Cells(MaLigne, 1).Resize(1, 7).Value = Array(Environ("USERNAME"), _
                                                              Cells(Target.Row, 2).Value, _
                                                              ValCell, Target.Value, _
                                                              IIf(Target.Column = 4, "Révision " & Target.Value & " du document " & Cells(Target.Row, 2).Value, _
                                                              "Prise en compte de la révision " & Target.Value & " du document " & Cells(2, Target.Column).Value), _
                                                              Date, _
                                                              Hour(Now) & ":" & Minute(Now))
Worksheets("Modifications").Protect (123)
     End With
     End If
Application.EnableEvents = True
 
If Not Application.Intersect(Target, Range("F6:BXY2000")) Is Nothing Then
     Continuer = MsgBox(IIf(Target.Column = 4, "Êtes-vous certain de modifier la révision ", "Êtes-vous certain d'avoir pris en compte cette révision"), vbYesNo + vbExclamation + vbDefaultButton2)
    Application.EnableEvents = False
    Target = UCase(Target)
    Application.EnableEvents = True
Else
    Exit Sub
End If
 
Worksheets("Modifications").Unprotect (123)
Application.EnableEvents = False
    With Worksheets("Modifications")
        ' calcul de la première ligne vide sur les 8 colonnes
        MaLigne = .UsedRange.Resize(, 8).Find("*", , , , xlRows, xlPrevious).Row + 1
 
        ' si on ne continue pas
        If Continuer = vbNo Then
            Target.Value = ValCell
 
        ' si on continue
        Else
                If Not Application.Intersect(Target, Range("F6:BXY2000")) Is Nothing And Target.Value > Cells(4, Target.Column) Then
                MsgBox ("vous ne pouvez prendre en compte une mise à jour du document " & Cells(2, Target.Column) & " supérieure à " & Cells(4, Target.Column))
                Target.Value = ValCell
 
                Else
                Pourquoi.Show
                ' on injecte les 8 valeurs directement en passant un tableau
                .Cells(MaLigne, 1).Resize(1, 8).Value = Array(Environ("USERNAME"), _
                                                              Cells(Target.Row, 2).Value, _
                                                              ValCell, Target.Value, _
                                                              IIf(Target.Column = 4, "Révision " & Target.Value & " du document " & Cells(Target.Row, 2).Value, _
                                                              "Prise en compte de la révision " & Target.Value & " du document " & Cells(2, Target.Column).Value), _
                                                              Date, _
                                                              Hour(Now) & ":" & Minute(Now), Pourquoi.TextBox1.Text)
 
Worksheets("Modifications").Protect (123)
                End If
         End If
     End With
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Application.Intersect(Target, Range("D6:D2000")) Is Nothing _
  Or Not Application.Intersect(Target, Range("F6:BXY2000")) Is Nothing Then
ValCell = Target
End If
End Sub
 
Private Sub CommandButton21_Click()
With ActiveCell
  If .Row < 3 Or .Column > 1 Or .Text = "" Then Exit Sub
  On Error Resume Next
  With Intersect(.Offset(, 1).Resize(, Columns.Count - 1), Me.UsedRange)
    .SpecialCells(xlCellTypeBlanks).EntireColumn.Hidden = True
  End With
End With
End Sub
 
Private Sub CommandButton22_Click()
Columns.Hidden = False
End Sub
 
Private Sub CommandButton23_Click()
Ajoutdoc.Show
Unload Ajoutdoc
End Sub

Comment "autoriser" les 2

**RyuAutodidacte** · 10/01/2017, 13h51

Les Macros sont elles dans le même module ?? si c'est le cas voir en copiant le code dans un nouveau module…

La j'ai pas trop le temps de regarder le code qui pose problème

PS : je travail sans "Option explicit" dans mon code (je pense avoir déclaré toutes les variables là mais je ne peux vérifier de suite)

**nananinanana** · 10/01/2017, 14h15

Pas de soucis déjà avec toute l'aide apportée je ne vais pas me plaindre ! Je vais essayer de voir comment faire fonctionner les 2 !!

Merci encore !

**RyuAutodidacte** · 10/01/2017, 14h22

Le code corrigé marche dans un nouveau module ??
Attention je n'ai pas complètement terminé le code, là c'était déjà au moins pour tester le principal et le valider, j'ai encore des choses à faire dessus et voir si je peux l'améliorer

**nananinanana** · 10/01/2017, 14h51

Celle proposée oui, la mienne non je n'ai même pas de messages d'erreur pour comprendre d'où vient le problème..

**RyuAutodidacte** · 10/01/2017, 15h07

PS : petite correction de mon code en ligne 37 :

Code :

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

If Coll.Count = 0 Then Coll.Add Itm, Cle Else If L = 1 Then Coll.Add Itm, Cle, L Else Coll.Add Itm, Cle, , L - 1

Est il possible de rencontré des lignes vides entre les docs dans la feuille de destination ??
Dans la feuille origine dans le cas ou l'une (ou plusieurs) des 5 colonnes n'est pas remplie, que se passe t-il ?? car cela fausses le nom d'un doc à la concaténation si cela arrive

qu'en est il ??

**nananinanana** · 10/01/2017, 15h23

Il faudra concatener les cellules non vides, il sera comparé à un document de la même forme alors il n'y aura pas de référence faussée finalement.

**RyuAutodidacte** · 10/01/2017, 15h47

Que l'on concatène 3 cellules non vides ou ou 5 cellules dont 2 vides on aura le même résultat.

Donc quoiqu'il arrive la macro devra concaténer car le fichier aura été vérifié préalablement ??
Où devons nous faire une vérification pour éviter de prendre des noms de doc qui ne seraient pas complet ??

Edit : modification du code pour que les révisions chiffres soit prit en compte aussi :

Envoyé par nananinanana

- Les documents en ligne ont été réalisé avec les révisions A, B,…, Z ou 1, 2,…, n (que l'on peut lire à l'intérieur du tableau) des documents en colonne

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
Sub COPIEDONNEES()
Dim S_Doc(), S_Rev, DerL&, D_Doc(), D_Rev(), Coll As New Collection, i&, Itm, Cle, VScA, VScB
 
   'NomFichierEntree = Application.GetOpenFilename("Fichier Excel (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm")
 
   'If NomFichierEntree <> False Then
 
       'Workbooks.Open NomFichierEntree
       'Fichier = Right(NomFichierEntree, Len(NomFichierEntree) - InStrRev(NomFichierEntree, "\"))
 
       With ThisWorkbook ' Workbooks(Fichier)
           DerL = .Sheets("Feuille Origine").Cells(Rows.Count, 1).End(xlUp).Row
           S_Doc = .Sheets("Feuille Origine").Range("A9:F" & DerL).Value
           '.Close False
       End With
 
       For i = 1 To UBound(S_Doc)
           S_Doc(i, 1) = S_Doc(i, 1) & S_Doc(i, 2) & S_Doc(i, 3) & S_Doc(i, 4) & S_Doc(i, 5)
           S_Doc(i, 2) = S_Doc(i, 6)
       Next
 
       ReDim Preserve S_Doc(1 To UBound(S_Doc), 1 To 2)
 
        DerL = Sheets("GMD").Cells(Rows.Count, 2).End(xlUp).Row
 
                On Error Resume Next
 
        If DerL > 5 Then
            D_Doc = Sheets("GMD").Range("B6:B" & DerL).Value: D_Rev = Sheets("GMD").Range("D6:D" & DerL).Value
 
            For i = LBound(D_Doc) To UBound(D_Doc)
                Itm = D_Doc(i, 1) & "_" & D_Rev(i, 1): Cle = CStr(D_Doc(i, 1))
                Coll.Add Itm, Cle
                If Err.Number = 457 Then
                        If IsNumeric(D_Rev(i, 1)) Then VDestA = CDbl(D_Rev(i, 1)) Else VDestA = D_Rev(i, 1)
                        If IsNumeric(Split(Coll(D_Doc(i, 1)), "_")(1)) Then VDestB = CDbl(Split(Coll(D_Doc(i, 1)), "_")(1)) Else VDestB = Split(Coll(D_Doc(i, 1)), "_")(1)
                    If D_Rev(i, 1) > Split(Coll(D_Doc(i, 1)), "_")(1) Then
                        L = IndexColl(Coll, D_Doc(i, 1)): Coll.Remove L
                        If Coll.Count = 0 Then Coll.Add Itm, Cle Else If L = 1 Then Coll.Add Itm, Cle Else Coll.Add Itm, Cle, , L - 1
                    End If
                    Err.Clear
                End If
            Next
        End If
 
        For i = LBound(S_Doc) To UBound(S_Doc)
            Itm = S_Doc(i, 1) & "_" & S_Doc(i, 2): Cle = CStr(S_Doc(i, 1)):
            Coll.Add Itm, Cle
            If Err.Number = 457 Then
                    If IsNumeric(S_Doc(i, 2)) Then VScA = CDbl(S_Doc(i, 2)) Else VScA = S_Doc(i, 2)
                    If IsNumeric(Split(Coll(S_Doc(i, 1)), "_")(1)) Then VScB = CDbl(Split(Coll(S_Doc(i, 1)), "_")(1)) Else VScB = Split(Coll(S_Doc(i, 1)), "_")(1)
                If VScA > VScB Then
                    L = IndexColl(Coll, S_Doc(i, 1)): Coll.Remove L
                    If Coll.Count = 0 Then Coll.Add Itm, Cle Else If L = 1 Then Coll.Add Itm, Cle, L Else Coll.Add Itm, Cle, , L - 1
                End If
                Err.Clear
            End If
        Next
 
            On Error GoTo 0
 
        ReDim D_Doc(1 To Coll.Count, 1 To 1): ReDim D_Rev(1 To Coll.Count, 1 To 1)
        For i = 1 To Coll.Count
            D_Doc(i, 1) = Split(Coll(i), "_")(0): D_Rev(i, 1) = Split(Coll(i), "_")(1)
        Next
 
        Set Coll = Nothing
 
            Application.ScreenUpdating = False
 
        Sheets("GMD").Range("B6").Resize(UBound(D_Doc), UBound(D_Doc, 2)) = D_Doc
        Sheets("GMD").Range("D6").Resize(UBound(D_Rev), UBound(D_Rev, 2)) = D_Rev
 
            Application.ScreenUpdating = True
 
    'End If
 
End Sub
 
 
Function IndexColl(Macoll As Collection, ByVal V As String) As Long
    For i = 1 To Macoll.Count
        If Macoll(i) = Macoll(V) Then
            IndexColl = i: Exit Function
        End If
    Next
End Function

Bonjour,
Comme les noms des docs ont une nomenclature fait par la concaténation des 5 colonnes de la feuille origine,
On peut prévoir une sécurité en prenant en compte le nombre minimum de caractères qui compose le nom des docs afin de vérifier avec len si la longueur est valide.
Cela évitera de se retrouver avec une erreur dans la destination

PS : mise à jour du code dans post précédent

Edit : quel est ce nombre minimum ??

Re,
j'ai fait des petites modifications du code et rajouté des commentaires.
Où en êtes vous ??

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
100
101
Sub COPIEDONNEES()
Dim S_Doc(), S_Rev, DerL&, D_Doc(), D_Rev(), Coll As New Collection, i&, Itm$, Cle$, VDestA, VDestB, VScA, VScB, C
 
   'NomFichierEntree = Application.GetOpenFilename("Fichier Excel (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm")
 
   'If NomFichierEntree <> False Then
 
       'Workbooks.Open NomFichierEntree
       'Fichier = Right(NomFichierEntree, Len(NomFichierEntree) - InStrRev(NomFichierEntree, "\"))
 
       With ThisWorkbook ' Workbooks(Fichier)
           DerL = .Sheets("Feuille Origine").Cells(Rows.Count, 1).End(xlUp).Row 'Dernière ligne
           S_Doc = .Sheets("Feuille Origine").Range("A9:F" & DerL).Value 'Création du tableau des données de Origine
           '.Close False
       End With
 
       For i = 1 To UBound(S_Doc) 'Boucle de contaénation de 5 colonnes provenant de Origine dans un tableau + les révisions déplacer en col 2
           S_Doc(i, 1) = S_Doc(i, 1) & S_Doc(i, 2) & S_Doc(i, 3) & S_Doc(i, 4) & S_Doc(i, 5)
           S_Doc(i, 2) = S_Doc(i, 6)
       Next
        'on redimensionne le tableau sur 2 colonnes
       ReDim Preserve S_Doc(1 To UBound(S_Doc), 1 To 2)
 
        DerL = Sheets("GMD").Cells(Rows.Count, 2).End(xlUp).Row 'dernière ligne
 
                On Error Resume Next
 
        If DerL > 5 Then
        'on reprends dans un tableau les valeurs qui sont dans Destination
            D_Doc = Sheets("GMD").Range("B6:B" & DerL).Value: D_Rev = Sheets("GMD").Range("D6:D" & DerL).Value
 
            For i = LBound(D_Doc) To UBound(D_Doc) 'Boucle pour modifier ou ajouter dans la collection les Docs et révisions de Destination
                'Itm = Doc_Revision     -----   Cle = Doc => provenant de Destination
                Itm = D_Doc(i, 1) & "_" & D_Rev(i, 1): Cle = CStr(D_Doc(i, 1))
                Coll.Add Itm, Cle 'on ajoute l'item et la clé
                If Err.Number = 457 Then 'Si erreur => doublon
                        'VDestA = Valeur Destination A (Revision de Destination)
                        If IsNumeric(D_Rev(i, 1)) Then VDestA = CDbl(D_Rev(i, 1)) Else VDestA = D_Rev(i, 1)
                        'VDestB = Valeur Destination B (Revision déjà inscrite dans la collection)
                        If IsNumeric(Split(Coll(D_Doc(i, 1)), "_")(1)) Then VDestB = CDbl(Split(Coll(D_Doc(i, 1)), "_")(1)) Else VDestB = Split(Coll(D_Doc(i, 1)), "_")(1)
                    If VDestA > VDestB Then 'on vérifie les révisions d'un même Doc
                        'L = Réupération de l'index (emplacement) du Doc dans la collection afin de supprimer le Doc avec une REV moins récente
                        L = IndexColl(Coll, D_Doc(i, 1)): Coll.Remove L
                        'on ajoute le doc avec la révision plus récente dans la collection au même emplacement
                        If Coll.Count = 0 Then Coll.Add Itm, Cle Else If L = 1 Then Coll.Add Itm, Cle Else Coll.Add Itm, Cle, , L - 1
                    End If
                    Err.Clear
                End If
            Next
        End If
 
        For i = LBound(S_Doc) To UBound(S_Doc) 'Boucle pour modifier ou ajouter dans la collection les Docs et révisions de Origine
            'Itm = Doc_Revision     -----   Cle = Doc => provenant de Origine
            Itm = S_Doc(i, 1) & "_" & S_Doc(i, 2): Cle = CStr(S_Doc(i, 1))
            If Len(Cle) > 16 Then 'Mettre le nombre de caractère minimum correspondant au noms des docs
                Coll.Add Itm, Cle 'on ajoute l'item et la clé
                If Err.Number = 457 Then 'Si erreur => doublon
                        'VScA = Valeur source A (Revision de Origine)
                        If IsNumeric(S_Doc(i, 2)) Then VScA = CDbl(S_Doc(i, 2)) Else VScA = S_Doc(i, 2)
                        'VScB = Valeur source B (Revision déjà inscrite dans la collection)
                        If IsNumeric(Split(Coll(S_Doc(i, 1)), "_")(1)) Then VScB = CDbl(Split(Coll(S_Doc(i, 1)), "_")(1)) Else VScB = Split(Coll(S_Doc(i, 1)), "_")(1)
                    If VScA > VScB Then 'on vérifie les révisions d'un même Doc
                        'L = Réupération de l'index (emplacement) du Doc dans la collection afin de supprimer le Doc avec une REV moins récente
                        L = IndexColl(Coll, S_Doc(i, 1)): Coll.Remove L
                        'on ajoute le doc avec la révision plus récente dans la collection au même emplacement
                        If Coll.Count = 0 Then Coll.Add Itm, Cle Else If L = 1 Then Coll.Add Itm, Cle, L Else Coll.Add Itm, Cle, , L - 1
                    End If
                    Err.Clear
                End If
            End If
        Next
 
            On Error GoTo 0
        'on redimensionne les tableaux D_Doc et D_Rev à ma même dimension que la collection et on les alimente avec les valeurs correspondantes
        ReDim D_Doc(1 To Coll.Count, 1 To 1): ReDim D_Rev(1 To Coll.Count, 1 To 1): i = 0
        For Each C In Coll
            i = i + 1
            D_Doc(i, 1) = Split(C, "_")(0): D_Rev(i, 1) = Split(C, "_")(1)
        Next
 
        Set Coll = Nothing
 
            Application.ScreenUpdating = False
        'Mise à jour des colonnes Doc et Révision
        Sheets("GMD").Range("B6").Resize(UBound(D_Doc), UBound(D_Doc, 2)) = D_Doc
        Sheets("GMD").Range("D6").Resize(UBound(D_Rev), UBound(D_Rev, 2)) = D_Rev
 
            Application.ScreenUpdating = True
 
    'End If
 
End Sub
 
 
Function IndexColl(Macoll As Collection, ByVal V As String) As Long
    For i = 1 To Macoll.Count
        If Macoll(i) = Macoll(V) Then
            IndexColl = i: Exit Function
        End If
    Next
End Function

Edit : Le code au début a été mis sous forme de commentaires afin que je puisse faire mes tests

Edit 2: Modification de la fonction, mettre celle-ci à la place de la fonction qui est à la fin dans le code ci-dessus :

Code :

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

1
2
3
4
5
6
7
8
9
Function IndexColl(Macoll As Collection, ByVal V As String) As Long
Dim C, Indx&
    For Each C In Macoll
        Indx = Indx + 1
        If C = Macoll(V) Then
            IndexColl = Indx: Exit Function
        End If
    Next
End Function

**nananinanana** · 12/01/2017, 11h46

Merci beaucoup,

Je testerai demain car je n'ai pas accès à l'ordinateur avec les fichiers aujourd'hui, vraiment merci pour le temps accordé.

**RyuAutodidacte** · 13/01/2017, 10h36

Bonjour,
Petite précision :
On est bien d'accord que la comparaison des révisions se fait de (?) :
- lettre à lettre
OÙ
- de chiffre à chiffre
Et pas de lettre à chiffre ou inversement

Mes tests sur Excel montre que la lettre est toujours supérieur au chiffre

**nananinanana** · 16/01/2017, 09h24

Bonjour,

Oui la comparaison des révisions se fait de (?) :
Lettre à lettre ou de chiffre à chiffre pas de soucis la dessu, j'ai testé la macro et tout est plus que parfait !!!!
Encore merci, vous êtes un génie !

J'ai une petite question,

si je souhaite réutiliser votre code mais en recopiant les données d'un autre tableau sur 4 colonnes différentes et vérifier que la ligne n'est pas en doublons (et non la cellule), comment dois-je m'y prendre?

**RyuAutodidacte** · 16/01/2017, 10h56

Bonjour,
Oui, c'est possible, mais selon l'agencement des données, il faudra faire des modifications dans le code afin que cela correspond.
Dans ce cas là, on va se retrouvé avec une concaténation de la ligne sur les colonnes voulus afin de faire la comparaison.

En attendant lire se post : http://www.developpez.net/forums/d16...doublons-base/

**nananinanana** · 16/01/2017, 11h12

J'ai tenté avec ces modficiations mais le message d'erreur "l'indice n'appartient pas à la section" s'affiche

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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
Sub COPIEDONNEES()
Dim S_Op(), S_Eqp, DerL&, D_Op(), D_Eqp(), Coll As New Collection, i&, Itm$, Cle$
Dim S_Contr(), S_Conv(), D_Conv(), D_Contr()
Dim PlageR As Range, PlageR1 As Range, PlageR2 As Range, PlageR3 As Range
 
Set PlageR = Worksheets("data").Columns(7)
Set PlageR1 = Worksheets("ChargeCapa").Rows(4)
Set PlageR2 = Worksheets("ChargeCapa").Rows(5)
Set PlageR3 = Worksheets("ChargeCapa").Columns(2)
 
   'NomFichierEntree = Application.GetOpenFilename("Fichier Excel (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm")
 
   'If NomFichierEntree <> False Then
 
       'Workbooks.Open NomFichierEntree
       'Fichier = Right(NomFichierEntree, Len(NomFichierEntree) - InStrRev(NomFichierEntree, "\"))
Worksheets("data").Columns(7).NumberFormat = "dd/mm/yy;@"
Worksheets("ChargeCapa").Range("B4").CurrentRegion.Offset(1, 1).NumberFormat = "dd/mm/yy;@"
 
       With ThisWorkbook ' Workbooks(Fichier)
           DerL = .Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row
           S_Op = .Sheets("Data").Range("A2:H" & DerL).Value
           '.Close False
       End With
 
       For i = 1 To UBound(S_Op)
           S_Op(i, 1) = S_Op(i, 2)
           S_Op(i, 3) = S_Op(i, 6)
           S_Op(i, 4) = S_Op(i, 7)
           S_Op(i, 2) = S_Op(i, 8)
       Next
 
       ReDim Preserve S_Op(1 To UBound(S_Op), 1 To 4)
 
        DerL = Sheets("Historique de convocations").Cells(Rows.Count, 2).End(xlUp).Row
 
        On Error Resume Next
 
        If DerL > 2 Then
            D_Op = Sheets("Historique de convocations").Range("A2:A" & DerL).Value: _
            D_Eqp = Sheets("Historique de convocations").Range("B2:B" & DerL).Value: _
            D_Contr = Sheets("Historique de convocations").Range("C2:C" & DerL).Value: _
            D_Conv = Sheets("Historique de convocations").Range("D2:D" & DerL).Value
 
            For i = LBound(D_Op) To UBound(D_Op)
                Itm = D_Op(i, 1) & "_" & D_Eqp(i, 1) & "_" & D_Contr(i, 1) & "_" & D_Conv(i, 1): Cle = CStr(D_Op(i, 1))
                Coll.Add Itm, Cle
            Next
        End If
 
        For i = LBound(S_Op) To UBound(S_Op)
        If S_Op(i, 4) <> "" Then
 
        Vcc1 = S_Op(i, 1)
        Vcc2 = "debut"
        Vcc3 = S_Op(i, 2)
 
        Set trouveC1 = PlageR1.Cells.Find(what:=Vcc1, LookAt:=xlWhole)
            If Not trouveC1 Is Nothing Then
            Set trouveC2 = PlageR2.Cells.Find(what:=Vcc2, LookAt:=xlWhole)
                If Not trouveC2 Is Nothing Then
                Set trouveL = PlageR3.Cells.Find(what:=Vcc3, LookAt:=xlWhole)
                    If Not trouveL Is Nothing Then
 
                    At1 = trouveC1.Address
                    At2 = trouveC2.Address
                    At3 = trouveL.Address
 
                        If DateDiff("d", Now(), Worksheets("ChargeCapa").Cells(Range(At3).Row, Range(At1).Column)) <= 30 Then
                        Itm = S_Op(i, 1) & "_" & S_Op(i, 2) & "_" & S_Op(i, 3) & "_" & S_Op(i, 4): Cle = CStr(S_Op(i, 1)):
                        Coll.Add Itm, Cle
                        End If
 
                    End If
                End If
            End If
        End If
        Next
 
        On Error GoTo 0
 
        ReDim D_Op(1 To Coll.Count, 1 To 1): ReDim D_Eqp(1 To Coll.Count, 1 To 1): _
        ReDim D_Contr(1 To Coll.Count, 1 To 1): ReDim D_Conv(1 To Coll.Count, 1 To 1)
 
        For i = 1 To Coll.Count
            D_Op(i, 1) = Split(Coll(i), "_")(0): _
            D_Eqp(i, 1) = Split(Coll(i), "_")(1): _
            D_Contr(i, 1) = Split(Coll(i), "_")(2): _
            D_Conv(i, 1) = Split(Coll(i), "_")(3)
        Next
 
        Set Coll = Nothing
 
            Application.ScreenUpdating = False
 
        Sheets("Historique de convocations").Range("A2").Resize(UBound(D_Op), UBound(D_Op, 2)) = D_Op
        Sheets("Historique de convocations").Range("B2").Resize(UBound(D_Eqp), UBound(D_Eqp, 2)) = D_Eqp
        Sheets("Historique de convocations").Range("C2").Resize(UBound(D_Contr), UBound(D_Contr, 2)) = D_Contr
        Sheets("Historique de convocations").Range("D2").Resize(UBound(D_Conv), UBound(D_Conv, 2)) = D_Conv
 
            Application.ScreenUpdating = True
 
    'End If
 
End Sub
 
 
Function IndexColl(Macoll As Collection, ByVal V As String) As Long
    For i = 1 To Macoll.Count
        If Macoll(i) = Macoll(V) Then
            IndexColl = i: Exit Function
        End If
    Next
End Function

EDIT : Je n'ai plus l'erreur mais il ne gère pas les doublons pour toute la ligne mais pour la première cellule, je continue d'essaier d'approfondir le lien que vous m'avez envoyé pour résoudre ce problème

Faire appel à un autre classeur et supprimer les doublons sous conditions

Macros et VBA Excel

Discussions similaires

Partager

Partager