比較Excel VBA上的兩列

Question

我想使用VBA比較excel中的兩列。 我正在使用下面的代碼，但是它花了很長時間，因為有成千上萬的單元格。 我想設置一個最大限制，但不知道如何/在哪里應用。 我也不知道有人知道這種代碼更有效的方法嗎？

Private Sub CommandButton1_Click()
Dim Column1 As Range
Dim Column2 As Range

'Prompt user for the first column range to compare...
Set Column1 = Application.InputBox("Select First Column to Compare", Type:=8)

'Check that the range they have provided consists of only 1 column...
If Column1.Columns.Count > 1 Then
    Do Until Column1.Columns.Count = 1
        MsgBox "You can only select 1 column"
        Set Column1 = Application.InputBox("Select First Column to Compare", Type:=8)
    Loop
End If

'Prompt user for the second column range to compare...
Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)

'Check that the range they have provided consists of only 1 column...
If Column2.Columns.Count > 1 Then
    Do Until Column2.Columns.Count = 1
        MsgBox "You can only select 1 column"
        Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)
    Loop
End If

'Check both column ranges are the same size...
If Column2.Rows.Count <> Column1.Rows.Count Then
    Do Until Column2.Rows.Count = Column1.Rows.Count
        MsgBox "The second column must be the same size as the first"
        Set Column2 = Application.InputBox("Select Second Column to Compare", Type:=8)
    Loop
End If

'If entire columns have been selected, limit the range sizes
If Column1.Rows.Count = 11600 Then
    Set Column1 = Range(Column1.Cells(1), Column1.Cells(ActiveSheet.UsedRange.Rows.Count))
    Set Column2 = Range(Column2.Cells(1), Column2.Cells(ActiveSheet.UsedRange.Rows.Count))
End If

'Perform the comparison and set cells that are the same to yellow
Dim intCell As Long
For intCell = 1 To Column1.Rows.Count
    If Column1.Cells(intCell) = Column2.Cells(intCell) Then
        Column1.Cells(intCell).Interior.Color = vbYellow
        Column2.Cells(intCell).Interior.Color = vbYellow
    End If
Next
End Sub

謝謝。

Answer 1

我可能會提出一些可能有所幫助的調整。

1. 在比較循環運行時禁用屏幕更新。 您可以執行以下操作：

     Application.ScreenUpdating = False \n “您的循環在這里”\n Application.ScreenUpdating =真 

2. 將變量用於在代碼中重復的表達式，例如

     列1.行數 

我沒有測試過，但是檢查出來應該很快；）

Answer 2

屏幕更新會占用大量CPU資源，尤其是在更改單元格顏色時。 因此，@ zfdn.cat的答案肯定會幫助您。

但是，還有另一種想法：如果您的10000行中的許多行的顏色都發生了更改，那么通過跟蹤需要更改顏色的單元格並在循環結束后設置這些單元格的顏色，您還將看到性能的提高。

就像是...

Dim range_string as String
range_string = ""

Dim intCell As Long
For intCell = 1 To Column1.Rows.Count
    If Column1.Cells(intCell) = Column2.Cells(intCell) Then

        ' check if the range_string is empty
        ' if not, we'll add a comma to separate the next and previous points
        if range_string <> "" Then
            range_string = range_string & ","
        end if

        range_string = range_string & _
           Column1.Cells(intCell).Address & ":" &_
           Column1.Cells(intCell).Address & "," & _
           Column2.Cells(intCell).Address & ":" &_
           Column2.Cells(intCell).Address

    End If
Next

' Change the color of all the cells at once
Range(range_string).Interior.Color = vbYellow

我沒有測試代碼，但是算法很可靠...我認為

Answer 3

您可以嘗試以下操作（在13,46秒內完成100'000行）：

 Sub Main()

    Dim Col1 As Range
    Dim Col2 As Range
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim i As Long

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet1") ' Change the name of your Sheet


    Set Col1 = Application.InputBox("Select First Column to Compare", Type:=8)
    Set Col2 = Application.InputBox("Select First Column to Compare", Type:=8)

Application.ScreenUpdating = False

With ws
i = 1
Do While Not IsEmpty(.Cells(i, Col1.Column))

                If .Cells(i, Col1.Column) = .Cells(i, Col2.Column) Then
                    .Cells(i, Col1.Column).Interior.Color = vbYellow
                    .Cells(i, Col2.Column).Interior.Color = vbYellow
                End If
        i = i + 1
Loop

End With

Application.ScreenUpdating = True
End Sub