使用數組多個工作簿和工作表之間進行比較和共享數據

Question

我一直在寫了幾個星期的代碼，它用來工作，它了2個小時通過49個工作表中我比較，但由於某種原因它來編譯現在只是說沒有迴應。我真的想嘗試切換使用數組，以便如果我能夠再次使用它，它會快得多。然而，即使在閱讀了大量有關數組的帖子之後，我也無法想出辦法，除了知道我需要使用多維數組並且具有不同的行大小之外。任何人都可以提供任何建議嗎？提前致謝！

更多信息，代碼看什麼是E列，如果在E列別的東西與它匹配採用的值列牛逼通X，並將其放置在該行牛逼通X。如果它們的t通過x是空的，它也爲行e着色，或者如果發現它不應該被着色，則使它再次變成白色。

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

這個答案本來是爲Code Review site但這個問題被擱置，所以我會在這裏提供它

從你設法在最壞的情況下編碼性能的角度看 - 工作的最高金額需要完成任務。你可能做的只是得到它的工作，而且我上投票的問題，因爲你做了正確的決定，以尋求幫助

爲了說明考慮到我們有10個文件，每3張，並含有每片1,000行（份）。你的算法是循環遍歷每個文件，每個文件循環遍歷每個文件（！），每個工作表和每一行：

結果：10個文件* 3工作表* 1,000行= 30,000個搜索 - 與範圍

還有其他一些問題：

• 您覆蓋所有數據好幾次，包括空字符串
• 搜索部件編號覆蓋有效數據並不精確，因爲InStr函數的（）
• 更不用說像的命名約定使得代碼非常難讀，和GoTo語句基本問題不利於無論是

的第一步，以提高性能是你腦子裏是什麼：轉換爲陣列，但即使這樣也無法很好地處理大量的工作，因爲仍然存在大量的文件交互（一遍又一遍地遍歷它們），所以下一步是優化邏輯

當轉換爲陣列，主要概念來理解的是，一個陣列具有相同的結構在紙張上的數據 - 可以使用行和列，不同之處在於列不使用字母想象片材在內存中，所以如果複製數據到內存這樣做：dataArray = Sheet1.UsedRange，那麼你訪問它以同樣的方式：除了陣列

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

是指數級速度更快。您不必擔心2名維數組，如果讓事情複雜，因爲VBA在這個簡單的任務dataArray = Sheet1.UsedRange，其中dataArray應該然後定義爲Variant

生成正確的陣列中，只有完成所有處理後需要額外的步驟就是將數據與這一說法Sheet1.UsedRange = dataArray

所以，我提出的第一個版本是原來的（低效率）的邏輯，轉換成數組，只是爲了演示如何複製回表它可以做到

第二個版本是一種改進的算法遍歷所有文件，只有兩次

1. 一旦讀取所有的零件編號爲字典
2. 第二次更新所有的零件編號（通過缺少細節列ŧ X），在所有文件

結果與我的數據（3個文件，每個片材3，以及包含1000行，每行片）：

- 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) 

---

2版（陣列）：

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 

---

版本3（數組和字典）

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 

---

測試數據：

前 - 缺少數據的所有文件 - 所有文件，V1（你） -

---

後發現藍色輪廓記錄 - 無效數據

---

之後 - 所有文件，v2 - 與v1相同的問題，由陣列實現加強

---

後 - 所有文件，V3

---