I'm running a nested loop. I added an array in an attempt to speed it up.
When I have 100 rows and 41 columns of data in the "Active" sheet and 1000 rows and 41 columns of data in the "Closed" sheet, it takes about seven minutes to output the data into the "CompSheet".
Sub CompareColumns()
'Turn off screen updating and automatic calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Integer 'variable for the outer loop
Dim j As Integer 'variable for the inner loop
Dim ws As Worksheet 'variable for the sheet CompSheet
Dim compareLat As Byte 'variable for the column that is being compared
Dim compareLon As Byte 'variable for the column that is being compared
Dim compareLatArray As Byte
Dim compareLonArray As Byte
Dim uniqueID As String 'variable for the unique identifier
Dim ActiveSheetRows As Integer
Dim ClosedSheetRows As Integer
Dim closedArray As Variant ' variable for closed sheet data
Dim closedArrayRow As Variant
Dim activeArray As Variant ' variable for active sheet data
Dim activeArrayRow As Variant
Dim dLon As Double
Dim x As Double
Dim y As Double
Dim lat_a As Double
Dim lat_c As Double
Dim lon_a As Double
Dim lon_c As Double
Dim result As Double
Dim distance_toggle As Single
Dim distance As Single
ActiveSheetRows = Worksheets("Active").UsedRange.Rows.Count
ClosedSheetRows = Worksheets("Closed").UsedRange.Rows.Count
compareLat = 38 'change this variable to switch the column that is being compared
compareLon = 39 'change this variable to switch the column that is being compared
compareLatArray = 38 'change this variable to switch the column that is being compared
compareLonArray = 39 'change this variable to switch the column that is being compared
distance_toggle = 1.5
'Store the data from the "Closed" worksheet into the array
closedArray = Worksheets("Closed").UsedRange.Value
'Store the data from the "Active" worksheet into the array
activeArray = Worksheets("Active").UsedRange.Value
'Check if the sheet CompSheet exists, if not create it
On Error Resume Next
Set ws = ThisWorkbook.Sheets("CompSheet")
If ws Is Nothing Then
ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = "CompSheet"
'copy the header row from the "Closed" worksheet when it first creates the "CompSheet" worksheet
Worksheets("Closed").Rows(1).Copy _
Destination:=Worksheets("CompSheet").Range("A1")
'Add the column header "uniqueID" to the last cell in row 1 of the "CompSheet" worksheet
Worksheets("CompSheet").Cells(1, Worksheets("CompSheet").UsedRange.Columns.Count + 1).Value = "uniqueID"
'Add the column header "CompDistance" to the last cell in row 1 of the "CompSheet" worksheet
Worksheets("CompSheet").Cells(1, Worksheets("CompSheet").UsedRange.Columns.Count + 1).Value = "CompDistance"
End If
On Error GoTo 0
'Loop through all the rows in the "Active" worksheet starting on row 2
For i = 2 To UBound(activeArray, 1)
'Loop through the array to look up the data in the "Closed" worksheet
For j = 2 To UBound(closedArray, 1)
lat_a = activeArray(i, compareLat)
lat_c = closedArray(j, compareLatArray)
lon_a = activeArray(i, compareLon)
lon_c = closedArray(j, compareLonArray)
'Calculationg for D2R = 0.0174532925199433
'pi = 4 * Atn(1)
'D2R = pi / 180#
lat_a = 0.0174532925199433 * lat_a
lat_c = 0.0174532925199433 * lat_c
dLon = 0.0174532925199433 * (lon_c - lon_a)
x = Sin(lat_a) * Sin(lat_c) + Cos(lat_a) * Cos(lat_c) * Cos(dLon)
y = Sqr((Cos(lat_c) * Sin(dLon)) ^ 2 + (Cos(lat_a) * Sin(lat_c) - Sin(lat_a) * Cos(lat_c) * Cos(dLon)) ^ 2)
distance = WorksheetFunction.Atan2(x, y) * 3963.19
If distance <= distance_toggle Then
'Copy the row from the Closed worksheet to the CompSheet worksheet in the next available row
Worksheets("CompSheet").Rows(Worksheets("CompSheet").UsedRange.Rows.Count + 1).Insert
closedArrayRow = Worksheets("Closed").Cells(j, 1).Resize(1, UBound(closedArray, 2))
'Worksheets("CompSheet").Range("B1").Resize(UBound(closedArrayRow, 1), UBound(closedArrayRow, 2)).Value = closedArrayRow
Worksheets("CompSheet").Rows(Worksheets("CompSheet").UsedRange.Rows.Count).Resize(1, 41).Value = closedArrayRow
'Create a uniqueID by combining column 6 from both the Active and Closed worksheets with a space and "&" in between
uniqueID = activeArray(i, 5) & " " & "&" & " " & closedArray(j, 5)
'Paste the uniqueID in the next available column of the new row in the CompSheet worksheet
Worksheets("CompSheet").Cells(Worksheets("CompSheet").UsedRange.Rows.Count, compareLon + 1).Value = uniqueID
'Paste the distance value in the corresponding column of the new row in the CompSheet worksheet
Worksheets("CompSheet").Cells(Worksheets("CompSheet").UsedRange.Rows.Count, compareLon + 2).Value = distance
End If
Next j
Next i
'Formatting "CompSheet" Data
Worksheets("CompSheet").Columns.AutoFit
Worksheets("CompSheet").Range("AO:AO").NumberFormat = "#,##0.0"
Worksheets("CompSheet").UsedRange.Font.Bold = False
Worksheets("CompSheet").Cells(1, 1).EntireRow.Font.Bold = True
'Turn on screen updating and automatic calculation
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
In addition to arrays, I added other code, such as:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Google drive link for the Excel file. https://drive.google.com/file/d/1GfR5RbWcHFQC-5oY9izDOQWbzZkvBwXi/view?usp=share_link
My code took eight minutes. I'd like to scale this up to a dataset about 500 times this size. Which would take 60 hours to run based on a linear time calculation.
I'm trying to compare real estate listings (properties), properties that are currently listed for sale in the "Active" sheet to ones that are already sold, in the "Closed" sheet.
For every property (row) in the "Active" sheet, I need to check every sold property in the "Closed" sheet based on the distance toggle and if the sold property is within the specified distance (2 miles) then I want to copy the sold listing row from the "Closed" sheet into the "CompSheet" and also paste the Unique ID (both addresses concatenated) and the 'distance' variable, for that comparison.
Should take less than 10 seconds
Option Explicit
Sub CompareColumns()
'change these variable to switch the column that is being compared
Const compareLat = 38 'AL
Const compareLon = 39 'AM
Const compareLatArray = 38 'AL
Const compareLonArray = 39 'AM
Const distance_toggle = 1.5
Dim wb As Workbook
Dim wsClosed As Worksheet, wsActive As Worksheet, wsComp As Worksheet
Dim n As Long, rComp As Long, colsClosed As Long, t0 As Single: t0 = Timer
Set wb = ThisWorkbook
With wb
Set wsActive = .Sheets("Active")
Set wsClosed = .Sheets("Closed")
n = .Sheets.Count
On Error Resume Next
Set wsComp = .Sheets("CompSheet")
On Error GoTo 0
If wsComp Is Nothing Then
Set wsComp = .Sheets.Add(After:=.Sheets(n))
With wsComp
.Name = "CompSheet"
'copy the header row from the "Closed" worksheet
'when it first creates the "CompSheet" worksheet
wsClosed.Rows(1).Copy .Range("A1")
'Add the column header "uniqueID" and "CompDistance"
'to the end of row 1 of the "CompSheet" worksheet
colsClosed = .UsedRange.Columns.Count
.Cells(1, colsClosed + 1).Value = "uniqueID"
.Cells(1, colsClosed + 2).Value = "CompDistance"
'Formatting "CompSheet" Data
.Columns.AutoFit
.Range("AO:AO").NumberFormat = "#,##0.0"
.UsedRange.Font.Bold = False
.Cells(1, 1).EntireRow.Font.Bold = True
End With
Else
colsClosed = wsClosed.UsedRange.Columns.Count
End If
rComp = wsComp.UsedRange.Rows.Count + 1
End With
'Store the data from the "Active" and "Closed"
'worksheet into the array
Dim arActive, arClosed
arActive = wsActive.UsedRange.Value
arClosed = wsClosed.UsedRange.Value
Dim i As Long, j As Long, k As Long
Dim lat_a As Double, lon_a As Double, lat_c As Double, lon_c As Double
Dim x As Double, y As Double, dLon As Double, distance As Double
Dim uniqueID As String
'Calculationg for D2R = 0.0174532925199433
'pi = 4 * Atn(1)
'D2R = pi / 180#
Const FACTOR As Double = 1.74532925199433E-02
' dimension max possible rows
Dim arComp, z As Long
z = UBound(arActive) * UBound(arClosed)
ReDim arComp(1 To z, 1 To colsClosed + 2)
rComp = 0
'Loop through all the rows in the "Active" worksheet starting on row 2
For i = 2 To UBound(arActive, 1)
lat_a = arActive(i, compareLat) * FACTOR
lon_a = arActive(i, compareLon)
'Loop through the array to look up the data in the "Closed" worksheet
For j = 2 To UBound(arClosed, 1)
lat_c = arClosed(j, compareLatArray) * FACTOR
lon_c = arClosed(j, compareLonArray)
dLon = FACTOR * (lon_c - lon_a)
x = Sin(lat_a) * Sin(lat_c) + Cos(lat_a) * Cos(lat_c) * Cos(dLon)
y = Sqr((Cos(lat_c) * Sin(dLon)) ^ 2 + (Cos(lat_a) * Sin(lat_c) - Sin(lat_a) * Cos(lat_c) * Cos(dLon)) ^ 2)
distance = WorksheetFunction.Atan2(x, y) * 3963.19
If distance <= distance_toggle Then
'Create a uniqueID by combining column 6 from
'both the Active and Closed worksheets
'with a space and "&" in between
uniqueID = arActive(i, 5) & " " & "&" & " " & arClosed(j, 5)
'Copy the row from the Closed worksheet to the
'CompSheet worksheet in the next available row
'Paste the uniqueID and distance in the next available column
'of the new row in the CompSheet worksheet
rComp = rComp + 1
For k = 1 To colsClosed
arComp(rComp, k) = arClosed(j, k)
Next
arComp(rComp, k) = uniqueID
arComp(rComp, k + 1) = distance
End If
Next j
Next i
'Turn off screen updating and automatic calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
' result
Dim rngComp As Range
With wsComp
Set rngComp = .Cells(.UsedRange.Rows.Count + 1, "A")
Set rngComp = rngComp.Resize(rComp, colsClosed + 2)
rngComp = arComp
End With
'Turn on screen updating and automatic calculation
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Data written " & rngComp.Address, vbInformation, "Took " & Format(Timer - t0, "0.00 secs")
End Sub