使用数组多个工作簿和工作表之间进行比较和共享数据

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

---