Croisement de deux tableaux

Bonjour,

Données : : deux tableaux tab1 (2 Colonnes : A et B) et tab2 (2 Colonnes : B et C), qui ont une colonne en commun (Colonne B).

Algorithme :

Si la colonne C est vide et si colonne B de tab 2 = colonne B de tab1 alors incrémenter de 1, sinon ne pas incrémenter.

Résultat :

Grâce à un code que j'ai pu développer sur vba, j'arrive à avoir le nombre de lignes lorsque je limite le nombre de boucle.

Problème

Dans mon code(ci-dessous), j'utilise une double boucle, on fixe la 1er ligne de tab2 et on cherche dans tout tab1;

puis on va à la 2e ligne de tab2 et on cherche dans tout le tab1, ect...

Sachant que chaque tableaux fait 15.000 lignes, cela crée 15.000*15.000 opérations ce qui fait planter excel.

voici le code proposé :

Sub test()
    max_tab_1 = 15000
    max_tab_2 = 15000
    n = 0  
    Application.EnableEvents = False
    Application.ScreenUpdating = False
        For i = 2 To max_tab_1
            For j = 2 To max_tab_2
                If Worksheets("tab_2").Cells(i, 2) = "" Then
                     If Worksheets("tab_2").Cells(i, 1) = Worksheets("tab_1").Cells(j, 2) Then
                                                n = n + 1                           
                     End If          
                End If
            Next    
        Next
        Worksheets("resultat").Cells(1, 1) = n
        Application.EnableEvents = True  
        Application.ScreenUpdating = True
End Sub

Pouvez vous me proposer s'il vous plait, une solution plus optimisée ou une autre manière de faire ?

j'ai essayé avec les tableaux croisée dynamique sauf qu'au niveau de la colonne B des deux tableaux il y a des doublons, donc excel ne permet pas de crée des tcd.

merci

cdlt

abv02 a écrit :

une autre manière de faire ?

Bonjour,

explore plusieurs autres pistes :

• trie les tableaux sur la colonne B et ensuite
  utilise la dichotomie pour trouver dans le second tableau la valeur correspondante

• ou bien ... progresse petit à petit sans tout balayer dans le second tableau

• importe les 2 tableaux dans des arrays pour être plus rapide

Une fonction de dichotomie à adapter

Function dichotomie(valeurcherchee As Variant) As Double
' donne la ligne de la valeur recherchée (0 si pas trouvé)
Dim ws As Worksheet
Dim deb As Double, fin As Double, milieu As Double
Dim valeurcourante As Variant

    dichotomie = 0
    deb = 2
    Set ws = Sheets("data")
    fin = ws.Range("A1").End(xlDown).Row
    While deb <> fin - 1
        milieu = Int((deb + fin) / 2)
        valeurcourante = ws.Range("A" & milieu)
        If valeurcourante = valeurcherchee Then
            dichotomie = milieu
            Exit Function
        Else
            If valeurcourante > valeurcherchee Then
                fin = milieu
            Else
                deb = milieu
            End If
        End If
    Wend

End Function

Mieux vaut l'appliquer sur des arrays plutôt que des cells afin d'être encore plus rapide.

Merci pour votre retour.

Le soucis c'est la colonne B c'est un élément de type string donc ce n'est pas possible d'utiliser une dichotomie.

Avez vous une autre solution svp ?

Merci

abv02 a écrit :

Le soucis c'est la colonne B c'est un élément de type string donc ce n'est pas possible d'utiliser une dichotomie.

as-tu un jeu d'essai ?

Plus simple ...

Application.Match(x, t, 1)

la fonction match (cela équivaut à equiv) fonctionne par dichotomie avec le paramètre 1 et le tableau trié bien sûr

cela doit très notablement accélérer

reste ensuite à utiliser des array

Function NumLigne(x As Variant) As Variant
    Dim r, t As Range
    Set t = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
    r = Application.Match(x, t, 1)
    If IsNumeric(r) Then
        If x = Range("A" & r + 1) Then
            NumLigne = r + 1
        Else
            NumLigne = "Valeur inexistante"
        End If
    Else
        NumLigne = "Valeur inexistante"
    End If
End Function

C'est mieux que la fonction dichotomie pure qui gère mal les majuscules/minuscules (problème de comparaison de valeurs)

Bonjour abv02

Tu en es où ? je suis prêt à poursuivre au-delà du match qui doit déjà apporter une plus grande rapidité.

Voici un test ...

temps = 1 seconde pour 20.000 lignes en feuille A et B

il y a 48 correspondances sur 20.000, c'est très faible et oblige match à aller en dichotomie jusqu'au bout dans plus de 99% des cas !

Sub comparer_v2()
Dim i As Double, j As Double, r As Variant, cpt As Integer
depart = Now
cpt = 0
finB = Sheets("B").Range("A" & Rows.Count).End(xlUp).Row
finA = Sheets("A").Range("A" & Rows.Count).End(xlUp).Row
Set Rng = Sheets("B").Range("A2:A" & finB)
For i = 2 To finA
    r = Application.Match(Sheets("A").Cells(i, 1).Value, Rng, 1)
    If IsNumeric(r) Then
        j = r
        If Sheets("A").Cells(i, 1).Value = Sheets("B").Cells(j + 1, 1).Value Then
            Debug.Print i, j + 1, Sheets("A").Cells(i, 1).Value, Sheets("B").Cells(j + 1, 1).Value
            cpt = cpt + 1
        End If
    End If
Next
Debug.Print cpt, Format(Now - depart, "hh:mm:ss")
End Sub

la méthode de double boucle est impossible au delà de 1000 lignes et fait 22 secondes si on se limite à 1000 lignes en feuille A et B