Excel VBA script assistance - vba

Question

I wrote a VBA script to compare fields in excel. Excel freezes the second I click the button. It never displays any error messages. Every time I try to run it I have to use control alt delete to close excel.
one of my variables is commented out because after I get this to work I plan on copying the data to a different sheet instead of changing the font. just an FYI
Private Sub CommandButton4_Click()
Dim rng1, rng2, cell1, cell2 As Range
Set rng1 = Worksheets("Main").Range("B:B")
Set rng2 = Worksheets("CSV Transfer").Range("D:D")
'Set rng3 = Worksheets("Data").Range("A:A")
For Each cell1 In rng1
For Each cell2 In rng2
If IsEmpty(cell2.Value) Then Exit For
If cell1.Value = cell2.Value Then
cell1.Font.Bold = True
cell1.Font.ColorIndex = 2
cell1.Interior.ColorIndex = 3
cell1.Interior.Pattern = xlSolid
cell2.Font.Bold = True
cell2.Font.ColorIndex = 2
cell2.Interior.ColorIndex = 3
cell2.Interior.Pattern = xlSolid
End If
Next cell2
Next cell1
End Sub
Edit: Entire post has been changed to reflect my actual issue.

Answer 1

Your macro isn't freezing, you just aren't giving it enough time to complete - which is a lonnnngggg time. Excel has a row limit of 1,048,576 rows, and you are comparing every single cell in each row to every single cell in the other row. That's a total of 1,099,511,627,776 cell comparisons. Assuming you can do 100,000 comparisons per second (which is probably a stretch even without the formatting), this will eventually complete in just over 127 days.
I'd suggest doing a couple of things. First, when you assign a range to a column like this...
Set rng1 = Worksheets("Main").Range("B:B")
...you get every possible cell - not just the used ones. Find the last non-empty cell in each column, and set your ranges based on that:
Dim LastRow As Long
Dim ColumnB As Range
With Worksheets("Main")
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
Set ColumnB = .Range("B1:B" + LastRow)
End With
This might get your run times onto the order of minutes or seconds instead of days unless you have a huge data set. To improve them further, stop requesting individual values from the worksheet one at a time and pull them into arrays:
Dim BValues As Variant
BValues = ColumnB.Value
Then, just loop through and compare values in memory. It might look something more like this (I pulled the formatting out into a Sub):
Private Sub CommandButton4_Click()
Dim LastRow As Long, MainSheet As Worksheet, CsvSheet As Worksheet
Set MainSheet = Worksheets("Main")
Set CsvSheet = Worksheets("CSV Transfer")
Dim MainValues As Variant
With MainSheet
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
MainValues = .Range("B1:B" & LastRow).Value
End With
Dim CsvValues As Variant
With CsvSheet
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
CsvValues = .Range("D1:D" & LastRow).Value
End With
Dim MainRow As Long, CsvRow As Long
For MainRow = LBound(MainValues) To UBound(MainValues)
For CsvRow = LBound(CsvValues) To UBound(CsvValues)
If MainValues(MainRow) = CsvValues(CsvRow) Then
FormatCell MainSheet, MainRow, 2
FormatCell CsvValues, CsvRow, 4
End If
Next
Next
End Sub
Private Sub FormatCell(sheet As Worksheet, formatRow As Long, formatCol As Long)
With sheet.Cells(formatRow, formatCol)
With .Font
.Bold = True
.ColorIndex = 2
End With
With .Interior
.ColorIndex = 3
.Pattern = xlSolid
End With
End With
End Sub
I'd also turn off ScreenUpdates at very least if your performance is still too low.