Сравнение двух столбцов в Excel VBA

Question

Я ищу для сравнения два столбца в excel с использованием VBA. Я использую приведенный ниже код, но он принимает возраст, потому что есть тысячи ячеек. Я ищу, чтобы установить максимальный предел, но не знаю, как и где его применять. Я также не знаю, знает ли кто-нибудь более эффективный способ сделать этот код?

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 
   'Your loop here' 
   Application.ScreenUpdating = True

2. использовать переменные для выражений, которые повторяются через код, как

   Column1.Rows.Count

Я не испытываю, но это должно быть довольно быстро, чтобы проверить его out;)

Answer 2

Обновление экрана - это огромный процессор сосать, особенно когда вы меняете цвета ячеек. Поэтому ответ @ 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

Вы можете попробовать это (100'000 строк 13, 46 секунд):

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