Question

我试图通过比较每个单元格值来比较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

谢谢！

Answer 1

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

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.

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

比较两张excel表的最佳方法是什么？

1 个答案: