Utilisation de tableaux pour comparer et partager des données entre plusieurs classeurs et feuilles de travail

Question

J'ai écrit ce code depuis quelques semaines et cela a l'habitude de travailler, il m'a fallu 2 heures pour compiler les 49 feuilles de travail que je compare, mais pour une raison quelconque maintenant dit simplement ne pas répondre. Je veux vraiment essayer d'utiliser des tableaux de sorte que si je peux le faire fonctionner à nouveau, ça ira beaucoup plus vite. Cependant, même après avoir lu beaucoup de messages sur les tableaux, je ne peux pas trouver un moyen de le faire, en plus de savoir que je dois utiliser un tableau multidimensionnel et avoir une taille de ligne variée. Quelqu'un peut-il donner des conseils? Merci d'avance! Plus d'informations, le code regarde ce qui est dans la colonne e et si quelque chose d'autre dans la colonne e correspond, il prend les valeurs dans les colonnes t à x et les place dans les lignes t à x. Il colore également les lignes e si leur t est x vide, ou le rend blanc s'il le trouve coloré alors qu'il ne devrait pas l'être.

Sub FindPart_FullWorkbooks() 

'If searching multiple worksheets & workbooks 

Dim PartNumber As String 
Dim Found1 As Integer 
Dim Found2 As Boolean 
Dim Found3 As Boolean 
Dim Found4 As Boolean 
Dim Found5 As Boolean 
Dim Found6 As Boolean 
Dim Found7 As Boolean 
Dim Found8 As Boolean 
Dim Found9 As Boolean 
Dim Found10 As Boolean 
Dim Found11 As Boolean 
Dim Found12 As Boolean 
Dim EOS As String 
Dim EOSL As String 
Dim EOL As String 
Dim Replace As String 
Dim AddInfo As String 
Dim n As Long 
Dim m As Long 
Dim LastRow As Long 
Dim WS As Worksheet 
Dim WS2 As Worksheet 
Dim WB As Workbook 
Dim WB2 As Workbook 

For Each WB In Workbooks 

For Each WS In WB.Worksheets 

With WS 
LastRow = .Range("A1").SpecialCells(xlCellTypeLastCell).Row 
End With 

For m = 1 To LastRow 

    PartNumber = WB.Sheets(WS.Name).Cells(m, 5).Value 
    EOS = WB.Sheets(WS.Name).Cells(m, 20).Value 
    EOSL = WB.Sheets(WS.Name).Cells(m, 21).Value 
    EOL = WB.Sheets(WS.Name).Cells(m, 22).Value 
    Replace = WB.Sheets(WS.Name).Cells(m, 23).Value 
    AddInfo = WB.Sheets(WS.Name).Cells(m, 24).Value 

    Found2 = IsEmpty(WB.Sheets(WS.Name).Cells(m, 5).Value) 
    Found4 = IsEmpty(WB.Sheets(WS.Name).Cells(m, 20).Value) 
    Found5 = IsEmpty(WB.Sheets(WS.Name).Cells(m, 21).Value) 
    Found6 = IsEmpty(WB.Sheets(WS.Name).Cells(m, 22).Value) 
    Found7 = IsEmpty(WB.Sheets(WS.Name).Cells(m, 23).Value) 
    Found8 = IsEmpty(WB.Sheets(WS.Name).Cells(m, 24).Value) 

    If Found2 = True Then 
    GoTo NextIndex 

     Else 

     For Each WB2 In Workbooks 
     For Each WS2 In WB2.Worksheets 

      For n = 1 To LastRow 

       Found1 = InStr(WB2.Sheets(WS2.Name).Cells(n, 5).Value, PartNumber) 

       Found3 = IsEmpty(WB2.Sheets(WS2.Name).Cells(n, 20).Value) 
       Found9 = IsEmpty(WB2.Sheets(WS2.Name).Cells(n, 21).Value) 
       Found10 = IsEmpty(WB2.Sheets(WS2.Name).Cells(n, 22).Value) 
       Found11 = IsEmpty(WB2.Sheets(WS2.Name).Cells(n, 23).Value) 
       Found12 = IsEmpty(WB2.Sheets(WS2.Name).Cells(n, 24).Value) 

       If Found3 = True And Found9 = True And Found10 = True And Found11 = True And Found12 = True Then 

        If Found1 = 1 Then 
         WB2.Sheets(WS2.Name).Cells(n, 20).Value = EOS 
         WB2.Sheets(WS2.Name).Cells(n, 21).Value = EOSL 
         WB2.Sheets(WS2.Name).Cells(n, 22).Value = EOL 
         WB2.Sheets(WS2.Name).Cells(n, 23).Value = Replace 
         WB2.Sheets(WS2.Name).Cells(n, 24).Value = AddInfo 

        End If 
       End If 
      Next n 

     If Found4 = True And Found5 = True And Found6 = True And Found7 = True And Found8 = True Then 

     WB.Sheets(WS.Name).Cells(m, 5).Interior.Color = RGB(255, 0, 255) 

     ElseIf WB.Sheets(WS.Name).Cells(m, 5).Interior.Color = RGB(255, 0, 255) Then 

     WB.Sheets(WS.Name).Cells(m, 5).Interior.Color = RGB(255, 255, 255) 

     End If 

     'MsgBox (WB2.Name & " " & WS2.Name) 

     Next WS2 
     Next WB2 

    End If 
'MsgBox (m) 
NextIndex: 

Next m 
'MsgBox (WB.Name & " " & WS.Name) 

Next WS 
Next WB 

End Sub 

Answer 1

Cette réponse a été destinée à la Code Review site, mais cette question est en attente, donc je vais donner ici

Du point de vue de la performance vous avez réussi à coder le pire scénario - montant maximum de travail nécessaire pour accomplir la tâche. Vous l'avez probablement fait juste pour le faire fonctionner, et je suis en train de voter la question parce que vous avez pris la bonne décision pour demander de l'aide

Pour illustrer considérons que nous avons 10 fichiers, avec 3 feuilles chacun, et chaque feuille contenant 1000 lignes (parties). Ce que votre algorithme fait est boucle à travers chaque fichier, et pour chaque boucle de fichier à travers chaque fichier (!), Chaque feuille, et chaque ligne:

Résultat: 10 fichiers * 3 feuilles * 1000 lignes = 30 000 recherches - interractions avec la gamme

Il y a d'autres questions aussi bien:

• vous écrasez toutes les données à plusieurs reprises, y compris la superposition de données valides avec des chaînes vides
• Recherche d'un numéro de pièce n'est pas précis en raison de la InStr()
• Sans parler des questions de base comme une convention de nommage qui rend le code très difficile à lire, et l'instruction GoTo qui ne contribue pas non plus

La première étape pour améliorer la performance est ce que vous aviez en tête: convertir tableaux, mais même cela ne peut pas très bien faire face à l'énorme quantité de travail, car il ya encore beaucoup d'interaction de fichiers (en les parcourant encore et encore), donc la prochaine étape est d'optimiser la logique

convertissant en tableaux, le concept principal à comprendre est qu'un tableau a la même structure que les données sur la feuille - vous pouvez imaginer la feuille en mémoire en utilisant des lignes et des colonnes, sauf que les colonnes n'utilisent pas de lettres, donc si vous copiez le données à la mémoire en faisant ceci: dataArray = Sheet1.UsedRange, vous pouvez y accéder de la même manière:

• Sheet1.UsedRange.Cells(1, 1) = A1
• dataArray(1, 1) = A1

sauf les tableaux sont exponentiellement plus rapidement.Vous ne devez pas vous inquiéter au sujet des 2 dimensions du tableau, si cela rend les choses compliquées, parce que VBA génère le tableau approprié dans cette simple affectation dataArray = Sheet1.UsedRange, où dataArray doit être défini comme un Variant

Ensuite, le seule étape supplémentaire nécessaire après tout traitement est terminé est de copier les données à la feuille avec cette déclaration Sheet1.UsedRange = dataArray

la première version que je fait est la logique (inefficace) d'origine, converti en tableaux, juste pour montrer comment cela peut être fait

La deuxième version est un algorithme amélioré qui itère sur tous les fichiers, seulement deux fois

1. Une fois de lire tous les numéros de pièce dans un dictionnaire
2. 2ème temps de mettre à jour tous les numéros de pièce (manque les détails dans les colonnes T par X), dans tous les fichiers

résultats avec mes données (3 fichiers, avec 3 feuilles chacun, et chaque feuille contenant 1000 lignes):

- v1: Time: 4399.262 sec (1.22 hrs) - your version 
- v2: Time: 770.797 sec (12.8 min) - your version converted to arrays 
- v3: Time: 2.684 sec   - optimized logic (arrays + dictionary) 

---

Version 2 (tableaux):

Public Sub FindPart_FullWorkbooks3() '----------------------------------------------- 
    Const FR = 2 'First row, after header 
    Dim wb1 As Workbook, wb2 As Workbook, ws1 As Worksheet, ws2 As Worksheet 
    Dim ur1 As Variant, ur2 As Variant, info1 As String,info2 As String, updt As Boolean 
    Dim lr1 As Long, lr2 As Long, lc1 As Long, lc2 As Long, samePart As Boolean 
    Dim m(1 To 6), i As Byte, cel As Range, yColor As Long, nColor As Long 
    Dim r1 As Long, c1 As Long, r2 As Long, c2 As Long, y As Range, n As Range 

    yColor = RGB(255, 255, 255) 
    nColor = RGB(255, 0, 0) 

    m(1) = 5 
    m(2) = 20 
    m(3) = 21 
    m(4) = 22 
    m(5) = 23 
    m(6) = 24 

    For Each wb1 In Workbooks 
     For Each ws1 In wb1.Worksheets 
      ur1 = ws1.UsedRange 
      lr1 = UBound(ur1, 1) 'last row 
      lc1 = UBound(ur1, 2) 'last col 
      If lc1 >= 24 Then 
       For r1 = FR To lr1 
        If Len(ur1(r1, m(1))) > 0 Then 
         info1 = ur1(r1, m(2)) & ur1(r1, m(3)) & ur1(r1, m(4)) 
         info1 = info1 & ur1(r1, m(5)) & ur1(r1, m(6)) 
         Set cel = ws1.Cells(r1, m(1)) 
         If Len(info1) > 0 Then 
         For Each wb2 In Workbooks 
          For Each ws2 In wb2.Worksheets 
          ur2 = ws2.UsedRange 
          lr2 = UBound(ur2, 1) 
          lc2 = UBound(ur2, 2) 
          If lc2 >= 24 Then 
           For r2 = FR To lr2 
           info2 = ur2(r2, m(2)) & ur2(r2, m(3)) & ur2(r2, m(4)) 
           info2 = info2 & ur2(r2, m(5)) & ur2(r2, m(6)) 
           samePart = InStr(ur2(r2, m(1)), ur1(r1, m(1))) = 1 
           If (samePart And Len(info2) = 0) Then 
            For i = 1 To 6 
             ur2(r2, m(i)) = ur1(r1, m(i)) 
            Next 
            updt = True 
           End If 
           Next 
          End If 
          If updt Then 
           ws2.UsedRange = ur2 
           updt = False 
          End If 
          Next 
         Next 
         If y Is Nothing Then Set y = cel Else Set y = Union(y, cel) 
         Else 
         If n Is Nothing Then Set n = cel Else Set n = Union(n, cel) 
         End If 
        End If 
       Next 
       If Not y Is Nothing Then 
        If y.Interior.Color = nColor Then y.Interior.Color = yColor 
        Set y = Nothing 
       End If 
       If Not n Is Nothing Then 
        n.Interior.Color = nColor 
        Set n = Nothing 
       End If 
      End If 
     Next 
    Next 
End Sub 

---

Version 3 (tableaux et Dictionnaire)

Public Function UpdateAllParts() As Long '------------------------------------------ 
    Const FR = 2 'First row, after header 
    Const DELIM = "<*>" 
    Dim wb As Workbook, ws As Worksheet, ur As Variant, i As Byte, iter As Long 
    Dim lr As Long, lc As Long, m(1 To 6), inf As String, frst As Boolean 
    Dim yColor As Long, nColor As Long, y As Range, n As Range, d As Dictionary 
    Dim cel As Range, lenDelim As Long, vals As Variant, r As Long, c As Long 

    yColor = RGB(255, 255, 255): nColor = RGB(255, 0, 0): Set d = New Dictionary 
    m(1) = 5: m(2) = 20: m(3) = 21: m(4) = 22: m(5) = 23: m(6) = 24 

    lenDelim = Len(DELIM) * 4 
    For iter = 1 To 2 
     frst = iter = 1 
     For Each wb In Workbooks 
     For Each ws In wb.Worksheets 
      ur = ws.Range(ws.Cells(1), ws.Cells.SpecialCells(xlCellTypeLastCell)) 
      lr = UBound(ur, 1): lc = UBound(ur, 2) 
      If lc >= 24 Then 
      For r = FR To lr 
       If Len(ur(r, m(1))) > 0 Then 
       If frst Then Set cel = ws.Cells(r, m(1)) 
       inf = ur(r, m(2)) & DELIM & ur(r, m(3)) & DELIM & ur(r, m(4)) 
       inf = inf & DELIM & ur(r, m(5)) & DELIM & ur(r, m(6)) 
       If frst Then 
        If Len(inf) > lenDelim Then 
         d(ur(r, m(1))) = inf 'add all to dict 
         If cel.Interior.Color = nColor Then 
          If y Is Nothing Then Set y = cel Else Set y = Union(y, cel) 
         End If 
        Else 
         If n Is Nothing Then Set n = cel Else Set n = Union(n, cel) 
        End If 
       Else 
        If Len(inf) = lenDelim Then 
        If d.Exists(ur(r, m(1))) Then 
         vals = Split(d(ur(r, m(1))), DELIM) 
         For i = 0 To 4 
         ur(r, m(i + 2)) = vals(i) 
         Next 
        End If 
        End If 
       End If 
       End If 
      Next 
      If frst Then 
       If Not y Is Nothing Then 
       If y.Interior.Color = nColor Then y.Interior.Color = yColor 
       Set y = Nothing 
       End If 
       If Not n Is Nothing Then 
       n.Interior.Color = nColor 
       Set n = Nothing 
       End If 
      Else 
       ws.Range(ws.Cells(1), ws.Cells.SpecialCells(xlCellTypeLastCell)) = ur 
      End If 
      End If 
     Next 
     Next 
    Next 
    UpdateAllParts = d.Count 
End Function 

---

données de test:

Avant - tous les fichiers avec des données manquantes

---

Après - tous les fichiers, v1 (le vôtre) - Notez les dossiers indiqués en bleu - Données invalides

---

Après - tous les fichiers, v2 - même problème que dans v1, accentué par l'implémentation de la matrice

---

Après - tous les fichiers, v3

---