chercher les doublons sur plusieurs feuilles

**huître** · 07/06/2011, 16h08

bonjour

j'ai un gros soucis

alors j'ai 6 feuilles "AAAA","BBBB","CCCC","DDDD","EEEE","DOUBLONS"

Dans la feuille "DOUBLONS" j'ai une matrice qui ressemble à ça

CLE AAAA BBBB CCCC DDDD EEEE TOTAL
N34 1 1 2
B56 1 1
R34 1 1

(ps:comme je n'arrive pas à faire un tableau sur ce forum j'ai mis des codes couleurs pour s 'y retrouver)
En faite ce que cette matrice dit => "on trouve la clé N34 dans la feuille AAAA"

Donc pour savoir dans quelle feuille se trouvent les doublons

j'utilise la formule

Code :

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

=NB.SI(AAAA!$AE:$AE;DOUBLONS!$A$2)

pour la 2 eme ligne 2 colonne du tableau par exemple et je tire la formule jusqu'en bas

Le problème c'est que c'est extrêmement lent, j'estime le temps de recalcul à deux minutes au minimum par colonne surtout que j'ai 15000 lignes dans la feuille doublons

donc existe t'il un moyen de faire cette matrice en vba en sachant que les clés et les libellés ("AAAA";....) sont déjà présent dans la feuille doublons

et je voudrais également savoir s'il existe une manière de supprimer toute les lignes ayant un total de 1 le plus rapidement possible

voilà merci d'avance

**mercatog** · 07/06/2011, 17h02

Bonjour

Une proposition (aussi lente en présence de beaucoup de données) mais bon, à tester

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
Dim LastLig As Long
Dim Frml As String, Feuille As String
Dim j As Byte
 
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
With Sheets("DOUBLONS")
    LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
    For j = 2 To 6
        Feuille = .Cells(1, j).Value
        Frml = "=IF(COUNTIF('" & Feuille & "'!$E:$E," & .Name & "!" & .Range("A2").Address(0, 1) & ")=0,"""",COUNTIF('" & Feuille & "'!$E:$E," & .Name & "!" & .Range("A2").Address(0, 1) & "))"
        With .Range(.Cells(2, j), .Cells(LastLig, j))
            .Formula = Frml
            .Value = .Value
        End With
    Next j
End With
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

**huître** · 07/06/2011, 17h19

j'ai essayé c'est très long malheureusement

j'ai quelques question sinon

que veut dire ?

Code :

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

1
2
.Calculation = xlCalculationManual
.Calculation = xlCalculationAutomatic

sinon j'avais eu sur ce site deux code assez interessant en terme de gain de temps et un peu du même style

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
Sub compteur()
Dim sh As Excel.Worksheet, orng As Excel.Range, v As Variant
Dim Ligne As Long, i As Long, j As Integer, k As Integer
 On Error GoTo errorhandler
 
For Each sh In ThisWorkbook.Worksheets(Array("AAR35", "AAR", "RST", "PCH", "EXP DIF"))
    Ligne = sh.Range("ae" & sh.Rows.Count).End(xlUp).Row
    Set orng = sh.Range("A1:AF" & Ligne)
    v = orng.Value
    Set v1orng = ThisWorkbook.Sheets("TABLEAU DE BORD").Range("A1:AF" & Ligne)
    v1 = v1orng.Value
    For i = 2 To Ligne
        For j = 4 To 27
            For k = 2 To 6
                If v1(k, 3) = sh.Name Then
                    If v1(1, j) = v(i, 32) Then
                        v1(k, j) = v1(k, j) + 1
                    End If
                End If
            Next k
        Next j
    Next i
    
    v1orng.Value = v1    
Next sh
 
Exit Sub
errorhandler:
msgbox Error
 
End Sub

et le code suivant:

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
Public Sub Balayage()
Application.DisplayAlerts = False
Dim feuil As Worksheet
 
'Balayage des Feuilles
For Each feuil In Worksheets
   If feuil.Name <> "TABLEAU DE BORD" And feuil.Name <> "MODE OP" Then cherchervaleur feuil
Next feuil
 
'Enregistrement du fichier
With ThisWorkbook
    .SaveAs Filename:=.Path & Application.PathSeparator & "chrono.xls"
End With
 
End Sub
Sub cherchervaleur(sh As Worksheet)
Dim tbl()
Dim plage As Range
Dim cel As Range
Dim adr As String
Dim i As Integer
Dim lavaleur As Integer
 
'Temps de départ
t1 = Timer
 
Application.ScreenUpdating = False
 
        With sh
        
                'Définition du critère
                lavaleur = 1
                
                .Activate
                'Recherche de la dernière ligne
                dercel = .Cells(.Rows.Count, 32).End(xlUp).Row
                'Définition de la zone de recherche
                Set plage = .Range("AF2:AF" & dercel)
                '1ère occurence trouvée
                Set cel = plage.Find(lavaleur, LookIn:=xlValues)                'Si la 1ère occurence n'est pas vide, on cherche toutes les suivantes
                If Not cel Is Nothing Then
                        
                        'Mise en mémoire de l'adresse de la 1ère occurence
                        adr = cel.Address
                        
                        Do
                        
                                i = i + 1
                                'Augmentation de la 2ème dimension du Tableau (nombre de lignes)
                                ReDim Preserve tbl(1 To 32, 1 To i)                                'Enrichissement des valeurs contenues sur la même ligne
                                'dans les colonnes j à gauche de l'occurence trouvée
                                For j = 1 To 32
                                        tbl(j, i) = cel.Offset(0, j - 32)
                                Next j
                                'Recherche de la prochaine occurence
                                Set cel = plage.FindNext(cel)
                        
                        'La recherche continue tant que l'occurence trouvée n'est pas la 1ère
                        Loop While adr <> cel.Address
                
                End If
                
                'Toutes les lignes de 2 à la dernière sont effacées
                .Rows("2:" & dercel).ClearContents
                'La feuille est enrichie des données du tableau
                .Range(Cells(1, 1), Cells(UBound(tbl, 2), UBound(tbl, 1))).Offset(1, 0) = Application.WorksheetFunction.Transpose(tbl())                Application.Goto Reference:=.Range("A1")                
        
        End With
 
'Variables réinitialisées
Set plage = Nothing
Set cel = NothingErase tbl
 
Debug.Print Timer - t1 & " secondes de traitement"
 
End Sub

Ces deux codes m'ont été très utile en matière de gain de temps mais le problème c'est que je ne l'ai comprend pas et surtout ce qui est en rouge

peut-on s'inspirer de ses codes pour régler le problème

voilà merci d'avance

**mercatog** · 08/06/2011, 14h36

Bonjour

Suite à ton autre sujet' ci-joint code à tester (et éventuellement à adapter à l'autre sujet)

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
Sub CompteDoublons()
Dim DerLg As Long, i As Long
Dim T() As Double, S As Double
Dim j As Byte, N As Byte
Dim TabF, A
 
TabF = Array("'EXP DIF'", "AAR", "AAR35", "RST", "PCH") 'Mettre ici toutes tes feuille où compter
N = UBound(TabF)
With Sheets("DOUBLONS")
    DerLg = .Range("A" & .Rows.Count).End(xlUp).Row
    A = .Range("A2:A" & DerLg).Value
    ReDim Preserve T(1 To DerLg, 1 To N + 2)
    For i = 1 To DerLg - 1
        S = 0
        For j = 2 To N + 3
            If j = N + 3 Then
                T(i, j - 1) = S
            Else
                T(i, j - 1) = Evaluate("COUNTIF(" & TabF(j - 2) & "!AE:AE,""" & A(i, 1) & """)")
                S = S + T(i, j - 1)
            End If
        Next j
    Next i
    .Range("B2").Resize(DerLg - 1, N + 2).Value = T
End With
End Sub

**huître** · 09/06/2011, 10h23

Voilà ce que je cherchais un exemple d'utilisation d'un tableau merci

est ce que tu peux me mettre des commentaires pour mieux comprendre comment fonctionne les variables tableaux?
(ps: je ne suis pas un habitué des tableaux et je n'ai pas trop compris le tuto)

merci d'avance

donc voilà ce que j'ai produit

est t'il possible de l'adapter avec un tableau???

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 formule()
With Sheets("DOUBLONS")
    derlg = Range("A" & Rows.Count).End(xlUp).Row
    Range("B2").FormulaR1C1 = _
        "=IF(ISERROR(VLOOKUP(RC[-1],'EXP DIF'!C[29],1,FALSE)),0,1)"
    Range("B2").AutoFill Destination:=Range("B2:B" & derlg), Type:=xlFillDefault
    Range("C2").FormulaR1C1 = "=IF(ISERROR(VLOOKUP(RC[-2],AAR!C[28],1,FALSE)),0,1)"
    Range("C2").AutoFill Destination:=Range("C2:C" & derlg), Type:=xlFillDefault
    Range("D2").FormulaR1C1 = _
        "=IF(ISERROR(VLOOKUP(RC[-3],AAR35!C[27],1,FALSE)),0,1)"
    Range("D2").AutoFill Destination:=Range("D2:D" & derlg), Type:=xlFillDefault
    Range("E2").FormulaR1C1 = "=IF(ISERROR(VLOOKUP(RC[-4],RST!C[26],1,FALSE)),0,1)"
    Range("E2").AutoFill Destination:=Range("E2:E" & derlg), Type:=xlFillDefault
    Range("F2").FormulaR1C1 = "=IF(ISERROR(VLOOKUP(RC[-5],PCH!C[25],1,FALSE)),0,1)"
    Range("F2").AutoFill Destination:=Range("F2:F" & derlg), Type:=xlFillDefault
    Range("G2").FormulaR1C1 = "=SUM(RC[-5]:RC[-1])"
    Range("G2").AutoFill Destination:=Range("G2:G" & derlg), Type:=xlFillDefault
        Range("B2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Selection.End(xlUp).Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
 
    Range("G1").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=7, Criteria1:="1"
    Rows("2:2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.delete Shift:=xlUp
    Selection.AutoFilter
 
End With
End Sub

j'ai testé ton code et il est très très long à charger même s'il marche impéc

l'idéal serait surtout de gagner le plus de temps possible

**mercatog** · 09/06/2011, 12h00

Avec ton 2ème code tu ne compte pas le nombre de doublons mais s'il y a au moins un doublons
Essaies 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
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
Sub CompteSiDoublons()
Dim DerLg As Long, LastLig As Long, i As Long, k As Long
Dim T() As Double, S As Double
Dim j As Byte, N As Byte
Dim TabF, A, AE
Dim x As Double
 
Application.ScreenUpdating = False
x = Timer
TabF = Array("EXP DIF", "AAR", "AAR35", "RST", "PCH")    'Mettre ici toutes tes feuille où compter
N = UBound(TabF)
With Sheets("DOUBLONS")
    DerLg = .Range("A" & .Rows.Count).End(xlUp).Row
    A = .Range("A2:A" & DerLg).Value
    ReDim Preserve T(1 To DerLg, 1 To N + 1)
    For j = 0 To N
        With Sheets(TabF(j))
            LastLig = .Cells(.Rows.Count, "AE").End(xlUp).Row
            AE = .Range("AE2:AE" & LastLig).Value
            For i = 1 To DerLg - 1
                For k = 1 To LastLig - 1
                    If AE(k, 1) = A(i, 1) Then
                        T(i, j + 1) = 1
                        Exit For
                    End If
                Next k
            Next i
        End With
    Next j
    .Range("B2").Resize(DerLg - 1, N + 1).Value = T
    With .Range("G2:G" & DerLg)
        .FormulaR1C1 = "=SUM(RC[-5]:RC[-1])"
        .Value = .Value
    End With
End With
MsgBox "Opération terminée en " & Timer - x & " secondes"
End Sub

Ci-joint tuto http://didier-gonard.developpez.com/...s-tableau-vba/

http://silkyroad.developpez.com/vba/tableaux/

**huître** · 09/06/2011, 12h08

non effectivement

enfaite je me suis mal exprimé dans mes besoins

j'ai oublié de préciser que j'ai dédoublonné les 5 feuilles

enfaite ce qui m'interesse c'est de réperer sur combien de feuilles on retrouve une clé XXXX

**mercatog** · 09/06/2011, 12h17

Essaies ce code
en colonne A tes cléfs en colonne B sera le résultat

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
Sub CompteSiDoublons()
Dim DerLg As Long, LastLig As Long, i As Long, k As Long
Dim T() As Double
Dim j As Byte, N As Byte
Dim TabF, A, AE
Dim x As Double
 
Application.ScreenUpdating = False
x = Timer
TabF = Array("EXP DIF", "AAR", "AAR35", "RST", "PCH")    'Mettre ici toutes tes feuille où compter
N = UBound(TabF)
With Sheets("DOUBLONS")
    DerLg = .Range("A" & .Rows.Count).End(xlUp).Row
    A = .Range("A2:A" & DerLg).Value
    ReDim Preserve T(1 To DerLg, 1)
    For j = 0 To N
        With Sheets(TabF(j))
            LastLig = .Cells(.Rows.Count, "AE").End(xlUp).Row
            AE = .Range("AE2:AE" & LastLig).Value
            For i = 1 To DerLg - 1
                For k = 1 To LastLig - 1
                    If AE(k, 1) = A(i, 1) Then
                        T(i, 1) = T(i, 1) + 1
                        Exit For
                    End If
                Next k
            Next i
        End With
    Next j
    .Range("B2:B" & DerLg).Value = T
End With
MsgBox "Opération terminée en " & Timer - x & " secondes"
End Sub

**huître** · 09/06/2011, 13h21

oui mais mon tableau comporte 6 colonnes

la 1er=>les clés
la 2eme=>(1 si on trouve la clé dans la feuille "PCH" sinon 0 )
la 3eme=>(1 si on trouve la clé dans la feuille "RST")
etc

ce tableau permettrait de reperer ou se trouve les clés et reperer les anomalies

donc mettre deux colonnes avec les totaux et la clés ne me permettrait pas de retrouver l'emplacement des clés

donc le total serait mis en lumière dans la dernière colonne

je viens de tester ton code

mon traitement dure 60 secondes (sub formule())

le tiens dure 54 secondes (sub CompteSiDoublons())

Je ne gagne pas beaucoup de temps

or moi c'est ça mon plus gros problème je n'arrive pas à gagner du temps

c'est trop long 60 secondes

d'autant plus que j'ai d'autre macro à executer derriere

Moi ce qu'il me faut c'est une fée ou un génie qui m'execute ce traitement en 3 secondes

**trash_07** · 09/06/2011, 14h35

comment sont présenté tes données dans les différentes feuilles?
"AAAA","BBBB","CCCC","DDDD","EEEE"

**huître** · 09/06/2011, 15h02

je pense qu'un exemple serait plus judicieux

dans cette matrice les libellés de EXP DIF jusqu'à PCH font reférence à un onglet ayant le mm nom donc

donc chaque feuille de EXP DIF jusqu'à PCH les clés se trouvent dans la colonne AE

Ce qui m'interesse c'est de remplir la matrice de la cellule B2 jusqu'à la fin du tableau (dernière ligne derniere colonne pleine)

donc moi j'obtiens cette matrice grace à 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
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
Sub formule()
With Sheets("DOUBLONS")
    derlg = Range("A" & Rows.Count).End(xlUp).Row
    Range("B2").FormulaR1C1 = _
        "=IF(ISERROR(VLOOKUP(RC[-1],'EXP DIF'!C[29],1,FALSE)),0,1)"
    Range("B2").AutoFill Destination:=Range("B2:B" & derlg), Type:=xlFillDefault
    Range("C2").FormulaR1C1 = "=IF(ISERROR(VLOOKUP(RC[-2],AAR!C[28],1,FALSE)),0,1)"
    Range("C2").AutoFill Destination:=Range("C2:C" & derlg), Type:=xlFillDefault
    Range("D2").FormulaR1C1 = _
        "=IF(ISERROR(VLOOKUP(RC[-3],AAR35!C[27],1,FALSE)),0,1)"
    Range("D2").AutoFill Destination:=Range("D2:D" & derlg), Type:=xlFillDefault
    Range("E2").FormulaR1C1 = "=IF(ISERROR(VLOOKUP(RC[-4],RST!C[26],1,FALSE)),0,1)"
    Range("E2").AutoFill Destination:=Range("E2:E" & derlg), Type:=xlFillDefault
    Range("F2").FormulaR1C1 = "=IF(ISERROR(VLOOKUP(RC[-5],PCH!C[25],1,FALSE)),0,1)"
    Range("F2").AutoFill Destination:=Range("F2:F" & derlg), Type:=xlFillDefault
    Range("G2").FormulaR1C1 = "=SUM(RC[-5]:RC[-1])"
    Range("G2").AutoFill Destination:=Range("G2:G" & derlg), Type:=xlFillDefault
        Range("B2").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Selection.End(xlUp).Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
 
    Range("G1").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=7, Criteria1:="1"
    Rows("2:2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.delete Shift:=xlUp
    Selection.AutoFilter
 
End With
End Sub

dans ce code j'applique les formules
ensuite je les copie colle en valeur pour supprimer toute les formules qui alourdissent le fichier et je supprime toutes les clés unique c'est à dire celle dont la somme est égal à 1

mais 60 secondes de traitement ça reste trop long

sinon j'ai deux trois questions:

que veut dire l'instruction Ubound et Redim Preserve???

Merci d'avance

**trash_07** · 09/06/2011, 15h09

Ubound permet de connaitre la taille de ton tableau.
Redim preserve permet de redimensionner le tableau tout en gardant l'intégrité des données présent dans celui-ci.
Si tu fait juste un redim du tableau, tu perds les données qu'il contenait.

**mercatog** · 09/06/2011, 15h27

Essaies 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
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Sub CompteSiDoublonsBis()
Dim DerLg As Long, LastLig As Long, i As Long
Dim T() As Long, x As Long
Dim j As Byte, N As Byte
Dim TabF, A, AE
Dim Res As String, tAE() As String
 
 
Application.ScreenUpdating = False
x = Timer
TabF = Array("EXP DIF", "AAR", "AAR35", "RST", "PCH")    'Mettre ici toutes tes feuille où compter par ordre par rapport aux titres de tes colonnes
N = UBound(TabF)
With Sheets("DOUBLONS")
    DerLg = .Range("A" & .Rows.Count).End(xlUp).Row
    A = .Range("A2:A" & DerLg).Value
    ReDim T(1 To DerLg - 1, 1 To N + 2)
    ReDim S(1 To DerLg - 1, 1 To 1)
    For j = 0 To N
        With Sheets(TabF(j))
            LastLig = .Cells(.Rows.Count, "AE").End(xlUp).Row
            AE = .Range("AE2:AE" & LastLig).Value
            ReDim tAE(1 To LastLig - 1)
            For i = 1 To LastLig - 1
                tAE(i) = AE(i, 1)
            Next i
            Res = Join(tAE, "|")
            For i = 1 To DerLg - 1
                If InStr(Res, A(i, 1)) > 0 Then
                    T(i, j + 1) = 1
                    T(i, N + 2) = T(i, N + 2) + 1
                End If
            Next i
            Erase tAE
            Erase AE
        End With
    Next j
    .Range("B2").Resize(DerLg - 1, N + 2).Value = T
End With
MsgBox "Opération terminée en " & Timer - x & " secondes"
End Sub

**huître** · 09/06/2011, 15h32

13 secondes génial merci

parcontre je vais être un peu chiant mais est ce que je peux avoir des commentaires explicatifs

j'aimerais bien comprendre le code pour assimiler l'algorithme pour plus d'autonomie

merci super

**mercatog** · 09/06/2011, 15h48

Un petit commentaire, mais n'oublie pas les tutos

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
Sub CompteSiDoublonsBis()
Dim DerLg As Long, LastLig As Long, i As Long
Dim T() As Long, x As Long
Dim j As Byte, N As Byte
Dim TabF, A, AE
Dim Res As String, tAE() As String
 
'Ici pour désactiver l'affichage écran (pour gagner des ms)
Application.ScreenUpdating = False
'Pour compter la durée de déroulement du code, tu peux l'enlever
x = Timer
'Mettre ici toutes tes feuille où compter par ordre par rapport aux titres de tes colonnes
TabF = Array("EXP DIF", "AAR", "AAR35", "RST", "PCH")
'N+1=le nombre de feuilles (commenbce en 0)
N = UBound(TabF)
With Sheets("DOUBLONS")
    'DerLg Dernière ligne remplie de feuille DOUBLONS (colonne A)
    DerLg = .Range("A" & .Rows.Count).End(xlUp).Row
    'A tableau reportant toutes les clés de la colonne A de feuille DOUBLONS
    'A tableau à Derlg-1 lignes et 2 colonnes
    A = .Range("A2:A" & DerLg).Value
    'On crée un tableau T de DerLg-1 lignes et 6 colonnes (au cas où tu as 5 feuilles, la 6ème pour le total)
    ReDim T(1 To DerLg - 1, 1 To N + 2)
    'On parcours les feuilles (indice j)
    For j = 0 To N
        'Avec la feuille TabF(j), regarde plus haut
        With Sheets(TabF(j))
            'LastLig: Dernière ligne remplie de feuille TabF(j) (colonne AE)
            LastLig = .Cells(.Rows.Count, "AE").End(xlUp).Row
            'AE tableau reportant toutes les clés de la colonne AE de feuille TabF(j)
            'AE tableau à LastLig-1 lignes et 2 colonnes
            AE = .Range("AE2:AE" & LastLig).Value
            'On veut avoir un tableau d'une dimension pour pouvoir utiliser Join
            'Pour cela on redimonsionne tAE et on le remplit avec les données de la première colonne de AE
            ReDim tAE(1 To LastLig - 1)
            For i = 1 To LastLig - 1
                tAE(i) = AE(i, 1)
            Next i
            'Res est un string comportant les données de tAE séparés par |
            Res = Join(tAE, "|")
            'on parcours le tableau A (clés)
            For i = 1 To DerLg - 1
                'Si la clé existe dans le mot constitué Res
                If InStr(Res, A(i, 1)) > 0 Then
                    'On remplit la ligne i et la colonne j+1 de T par 1 et la dernière dimension on somme les résultats
                    T(i, j + 1) = 1
                    T(i, N + 2) = T(i, N + 2) + 1
                End If
            Next i
            Erase tAE
            Erase AE
        End With
    Next j
    'On remplit notre plage directement à partir du tableau T
    .Range("B2").Resize(DerLg - 1, N + 2).Value = T
End With
MsgBox "Opération terminée en " & Timer - x & " secondes"
End Sub

chercher les doublons sur plusieurs feuilles

Macros et VBA Excel

Discussions similaires

Partager

Partager