我正在运行一个嵌套循环。我添加了一个数组以加快速度。
当我在“Active”表中有100行41列数据，在“Closed”表中有1000行41列数据时，将数据输出到“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
除了数组，我还添加了其他代码，比如：
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Excel 文件的 Google 驱动器链接。 https://drive.google.com/file/d/1GfR5RbWcHFQC-5oY9izDOQWbzZkvBwXi/view?usp=share_link
我的代码花了八分钟。我想将其扩展到这个大小的 500 倍左右的数据集。根据线性时间计算，这将需要 60 个小时才能运行。
我正在尝试比较房地产列表（属性），当前在“活动”表中列出的待售属性与“已关闭”表中已售出的属性。
对于“活动”表中的每个属性（行），我需要根据距离切换检查“已关闭”表中的每个已售出的属性，如果已售出的属性在指定距离（2 英里）内，那么我想将已售出的列表行从“已关闭”表复制到“CompSheet”中，并粘贴唯一 ID（两个地址连接）和“距离”变量，以进行比较。
应该少于 10 秒
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
到目前为止我发现的一件事是不需要的：
Worksheets("CompSheet").Rows(Worksheets("CompSheet").UsedRange.Rows.Count + 1).Insert
这看起来像是在底部添加一行。您不必在底部添加行，它们已经存在了——只需将其注释掉并在您的“复制”语句中添加 1，Rows.Count + 1.
Worksheets("CompSheet").Rows(Worksheets("CompSheet").UsedRange.Rows.Count + 1).Resize(1, 41).Value = closedArrayRow
这应该会更快。编译，但未经测试。
WorksheetFunctionInsertConstUsedRangeSub CompareColumns()
Const NUM_COLS As Long = 39
Const ID_COL As Long = 40
Const DIST_COL As Long = 41
Const COL_ACT_LAT As Long = 38
Const COL_ACT_LON As Long = 39
Const COL_CLS_LAT As Long = 38
Const COL_CLS_LON As Long = 39
Const DIST_TOGGLE As Double = 1.5
Dim wb As Workbook, wsActive As Worksheet, wsClosed As Worksheet, wsComp As Worksheet
Dim rngClosed As Range, rngActive As Range
Dim i As Long, j As Long
Dim closedArray As Variant, activeArray As Variant
Dim lat_a As Double, lat_c As Double, lon_a As Double, lon_c As Double
Dim distance As Double, lastRw As Long, destRw As Range
Set wb = ThisWorkbook
Set wsActive = wb.Worksheets("Active")
'if your data has no empty rows or columns
Set rngActive = wsActive.Range("A1").CurrentRegion.Resize(, NUM_COLS)
activeArray = rngActive.Value
Set wsClosed = wb.Worksheets("Closed")
Set rngClosed = wsClosed.Range("A1").CurrentRegion.Resize(, NUM_COLS)
closedArray = rngClosed.Value
'add the comparison sheet if not already present
On Error Resume Next 'ignore error if sheet is missing
Set wsComp = wb.Worksheets("CompSheet")
On Error GoTo 0 'stop ignoring errors as soon as it's no longer needed....
If wsComp Is Nothing Then
Set wsComp = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
wsComp.Name = "CompSheet"
wsClosed.Range("A1").Resize(1, NUM_COLS).Copy wsComp.Range("A1")
wsComp.Cells(1, ID_COL).Value = "uniqueID"
wsComp.Cells(1, DIST_COL).Value = "CompDistance"
lastRw = 1
Else
'find last row with any data
lastRw = wsComp.Cells.Find(What:="*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End If
Set destRw = wsComp.Rows(lastRw + 1) 'first empty row on comp sheet
For i = 2 To UBound(activeArray, 1) 'loop "active" array
lat_a = activeArray(i, COL_ACT_LAT) 'you can read these in the outer loop
lon_a = activeArray(i, COL_ACT_LON)
For j = 2 To UBound(closedArray, 1) 'loop "closed" array
lat_c = closedArray(j, COL_CLS_LAT)
lon_c = closedArray(j, COL_CLS_LON)
distance = DistanceCalc(lat_a, lon_a, lat_c, lon_c)
If distance <= DIST_TOGGLE Then
destRw.Cells(1).Resize(1, NUM_COLS).Value = rngClosed.Rows(j).Value
destRw.Cells(ID_COL).Value = activeArray(i, 5) & " " & "&" & " " & closedArray(j, 5)
destRw.Cells(DIST_COL).Value = distance
Set destRw = destRw.Offset(1, 0)
End If
Next j
Next i
With wsComp 'Formatting "CompSheet" Data
.Columns.AutoFit
.Range("AO:AO").NumberFormat = "#,##0.0"
.UsedRange.Font.Bold = False
.Cells(1, 1).EntireRow.Font.Bold = True
End With
End Sub
'Miles between (latA,lonA) and (latB,lonB)
Function DistanceCalc(latA As Double, lonA As Double, latB As Double, lonB As Double) As Double
Const RAD_MULT As Double = 1.74532925199433E-02
Dim dlon As Double, x As Double, y As Double
latA = latA * RAD_MULT
latB = latB * RAD_MULT
dlon = RAD_MULT * (lonB - lonA)
x = Sin(latA) * Sin(latB) + Cos(latA) * Cos(latB) * Cos(dlon)
y = Sqr((Cos(latB) * Sin(dlon)) ^ 2 + (Cos(latA) * Sin(latB) - Sin(latA) * Cos(latB) * Cos(dlon)) ^ 2)
'DistanceCalc = WorksheetFunction.Atan2(x, y) * 3963.19
DistanceCalc = ArcTan2(x, y) * 3963.19 'VBA version is faster
End Function
'VBA version of WorksheetFunction.Atan2
Function ArcTan2(x As Double, y As Double) As Double
Const PI As Double = 3.14159265358979
Const PI_2 As Double = 1.5707963267949
Select Case x
Case Is > 0
ArcTan2 = Atn(y / x)
Case Is < 0
ArcTan2 = Atn(y / x) + PI * Sgn(y)
If y = 0 Then ArcTan2 = ArcTan2 + PI
Case Is = 0
ArcTan2 = PI_2 * Sgn(y)
End Select
End Function
您可以做一些基本的事情来加快代码速度。最简单的是禁用屏幕更新和计算。您可以使用错误处理来确保它们重新启用。
Sub MyFasterProcess()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error GoTo Finally
Call MyLongRunningProcess()
Finally:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If Err > 0 Then Err.Raise Err
End Sub
有些人喜欢将其放入一些辅助函数，甚至是一个类来管理多个进程的状态。
长时间运行的进程最常见的罪魁祸首是读取和写入单元格。读取数组比读取范围内的单个单元格要快得多。
考虑以下几点：
Sub SlowReadWrite()
Dim src As Range
Set src = Range("A1:AA100000")
Dim c As Range
For Each c In src
c.Value = c.Value + 1
Next c
End Sub
这将需要非常非常长的时间。现在让我们用一个数组来做。读一遍。写一次。无需禁用屏幕更新或将计算设置为手动。这将与他们一样快。
Sub FastReadWrite()
Dim src As Range
Set src = Range("A1:AA100000")
'Read once.
Dim vals() As Variant
vals = r.Value
Dim r As Long, c As Long
For r = 1 To UBound(vals, 1)
For c = 1 To UBound(vals, 2)
vals(r, c) = vals(r, c) + 1
Next c
Next r
'Write once.
src.Value = vals
End Sub
您的代码看起来仍在循环中执行读/写操作，这让您变慢了。