1

我试图通过比较每个单元格值来比较 vba 中的两个 excel 表。有没有最好的方法来提高性能？

当我的 Excel 表中有超过 2000 到 3000 行时。执行大约需要 5 分钟。有没有办法优化这段代码？

Sub CompareWorksheets(WS1 As Worksheet, WS2 As Worksheet)

Dim dR As Boolean
Dim r As Long, c As Integer, m As Integer
Dim lrow1 As Long, lrow2 As Long, lrow3 As Long
Dim lcoloumn1 As Integer, lcoloumn2 As Integer,
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim dupCount As Long

With WS1.UsedRange
  lrow1 = .Rows.Count
  lcoloumn1 = .Columns.Count
End With

With ws2.UsedRange
  lrow2 = .Rows.Count
  lcoloumn2 = .Columns.Count
End With

maxR = lrow1
maxC = lcoloumn1

If maxR < lrow2 Then maxR = lrow2
If maxC < lcoloumn2 Then maxC = lcoloumn2
DiffCount = 0
lrow3 = 1

For i = 1 To maxR
  dR = True
  Application.StatusBar = "Comparing worksheets " & Format(i / maxR, "0 %") & "..."
  For r = 1 To maxR
      For c = 1 To maxC
          WS1.Select
          cf1 = ""
          cf2 = ""
          On Error Resume Next
          cf1 = WS1.Cells(i, c).FormulaLocal
          cf2 = ws2.Cells(r, c).FormulaLocal
          On Error GoTo 0
          If cf1 <> cf2 Then
              dR = False
              Exit For
          Else
              dR = True
          End If
      Next c
      If dR Then
       Exit For
      End If
   Next r
     If Not dR Then
      dupCount = dupCount + 1
      WS1.Range(WS1.Cells(i, 1), WS1.Cells(i, maxC)).Select
      Selection.Copy
      Worksheets("Sheet3").Select
      Worksheets("Sheet3").Range(Worksheets("Sheet3").Cells(lrow3, 1), Worksheets   ("Sheet3").Cells(lrow3, maxC)).Select
      Selection.PasteSpecial
      lrow3 = lrow3 + 1
      WS1.Select
      For t = 1 To maxC
          WS1.Cells(i, t).Interior.ColorIndex = 19
          WS1.Cells(i, t).Select
          Selection.Font.Bold = True
      Next t
    End If
  Next i
 End Sub

谢谢！

4

1 回答 1

3

可能最好的方法是将每个工作表的范围值传递给一个数组。
然后迭代数组的每个元素。

Sub test2()

Dim arr1(), arr2() As Variant
Dim i, j As Long

arr1 = Sheets("Sheet1").Range("A1:D4").Value
arr2 = Sheets("Sheet2").Range("A1:D4").Value

For i = 1 To UBound(arr1, 1)
    For j = 1 To UBound(arr1, 2)
        If arr1(i, j) = arr2(i, j) Then 'do the comparison here
            'code here
        End If
    Next j
Next i

End Sub

上面的代码仅用于相同的范围比较。
否则，您需要添加另一个循环。
希望这能让你开始。

更新：
下面是比较单元格公式的代码部分的等价物。

Dim arr1(), arr2() As Variant

Set WS1 = ThisWorkbook.Sheets("Sheet1")
Set WS2 = ThisWorkbook.Sheets("Sheet2")

arr1 = WS1.UsedRange.FormulaLocal
arr2 = WS1.UsedRange.FormulaLocal

lrow1 = UBound(arr1, 1)
lrow2 = UBound(arr2, 1)
lcolumn1 = UBound(arr1, 2)
lcolumn2 = UBound(arr2, 2)

maxR = lrow1
maxC = lcoloumn1

If maxR < lrow2 Then maxR = lrow2
If maxC < lcoloumn2 Then maxC = lcoloumn2

DiffCount = 0
lrow3 = 1

For i = 1 To maxR
    dR = True
    Application.StatusBar = "Comparing worksheets " & Format(i / maxR, "0 %") & "..."
    For r = 1 To maxR
        For c = 1 To maxC
            cf1 = ""
            cf2 = ""
            On Error Resume Next
            cf1 = arr1(i, c)
            cf2 = arr2(r, c)
            On Error GoTo 0
            If cf1 <> cf2 Then
                dR = False
                Exit For
            Else
                dR = True
            End If
        Next c
        If dR Then
            Exit For
        End If
    Next r
'the rest of your code goes here which i cannot comprehend.

我无法改进代码的其他部分，抱歉。
我无法想象你试图完成什么。
希望这对您有所帮助。

于 2013-10-11T06:45:00.913 回答