我有这段代码，但在以后的程序中运行得太慢了：
Sub Here()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim srchLen, srchLen2, srchLen4, srchLen5, gName, nxtRw As Integer
Dim g As Range
'Clear Sheet 2 and Copy Column Headings
Sheets(2).Cells.ClearContents
'Determine length of Search Column from Sheet3
srchLen = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row
'Loop through list in Sheet3, Column A. As each value is
'found in Sheet1, Column A, copy it top the next row in Sheet2
With Sheets(1).Columns("A")
For gName = 1 To srchLen
Set g = .Find(Sheets(3).Range("A" & gName), lookat:=xlWhole)
If Not g Is Nothing Then
nxtRw = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row + 1
g.EntireRow.Copy Destination:=Sheets(2).Range("A" & nxtRw)
End If
Next
End With
' stage 2 Check my Local Stocks
srchLen2 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
srchLen4 = Sheets(4).Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To srchLen4
For j = 1 To srchLen2
If Sheets(4).Rows(i).Columns(1).Value = Sheets(2).Rows(j).Columns(1).Value Then
Sheets(2).Rows(j).Columns(2).Value = Sheets(2).Rows(j).Columns(2).Value + Sheets(4).Rows(i).Columns(2).Value
End If
Next j
Next i
'EBAY CODE
srchLen2 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
srchLen5 = Sheets(5).Range("K" & Rows.Count).End(xlUp).Row
For j = 1 To srchLen2
For i = 1 To srchLen5
If Sheets(5).Rows(i).Columns(11).Value = "" Then i = i + 1
If Sheets(2).Rows(j).Columns(1).Value = Sheets(5).Rows(i).Columns(11).Value Then
Sheets(5).Rows(i).Columns(8).Value = Sheets(2).Rows(j).Columns(2).Value
End If
Next i
Next j
'website CODE
srchLen2 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
srchLen6 = Sheets(6).Range("G" & Rows.Count).End(xlUp).Row
For j = 1 To srchLen2
For i = 1 To srchLen6
If Sheets(6).Rows(i).Columns(7).Value = "" Then i = i + 1
If Sheets(2).Rows(j).Columns(1).Value = Sheets(6).Rows(i).Columns(7).Value Then
Sheets(6).Rows(i).Columns(9).Value = Sheets(2).Rows(j).Columns(2).Value
End If
Next i
Next j
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Call Calculate
End Sub
表1是我们经销商的库存清单，包含约65,000件物品（columnA = SKU）（ColumnB =数量）。
工作表2是一个结果页面，其中工作表3与工作表1进行比较，如果存在，则将其打印到工作表2中，然后在一种循环中将行线增加到下一行。
表1,2,3工作得很好，但计算过去' Stage 2 Check my local stocks时整个宏速度变慢。
eBay和网站代码似乎会因为FOR NEXT循环而减慢一切。
我在网络服务器上上传了一个小版the Excel file。请在运行之前对其进行病毒扫描。
将此代码复制粘贴到宏中，您应该很容易理解它的作用以及我想要实现的目标。它适用于我想要的东西，但它的速度很慢。
答案 0 :(得分：0)
总体建议：
在过程开始时将Excel范围转换为数组。花费这么多时间的部分原因是Excel一次只能访问一个单元，这比访问内部范围数据要花费更长的时间。
例如，在程序开始时，创建一个名为＆＃39; Website_Stock＆＃39;的对象类，包含您关注的所有属性（索引号，名称，数量等），然后为每个网站的库存定义一个数组。然后就像你已经做的那样，计算你上面的第一行和最后一行，但是然后说出以下几点：
For i = 1 to lastrow
Website_Stock(i).Index = Website_Stock_Range(x, y)
Next i
然后根据新创建的范围分配数组中的所有属性。类似的东西：
docker inspect $SWARM_AGENT_MASTER*这只是伪代码
然后在创建它的最后，您可以像上面一样使用For循环，并且每次都不需要访问Excel工作表进行更改。
答案 1 :(得分：0)
使用ADO查询工作表而不是循环将节省大量时间，我做了这些更改并粘贴下面的代码来运行。我认为它能满足您的需求！
1添加标题（SKU，数量到＆＃34;导入列表＆＃34;）
2添加标题（SKU，数量到＆＃34;亚马逊结果＆＃34;）
3添加标题（SKU到＆＃34;我们的产品＆＃34;）
在＆＃34;网站上传中更改了标题＆＃34;对它们进行编号而不是所有＆＃34;字段数据1＆＃34;
4添加名为＆＃34; dump＆＃34;
的工作表5将此代码添加到模块并运行
Const SourceDirectory As String = "C:\MyDirectory"
Const Filename As String = "sample.xlsm"
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Dim ws As Worksheet
Sub Here()
Set con = New ADODB.Connection
Set rs = New ADODB.Recordset
AddHeadersToAmazonResult
con.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & SourceDirectory & Filename & "; Extended Properties=""Excel 8.0;HDR=Yes;"";"
rs.Open "Select il.* FROM ([imported list$] il INNER JOIN [Our products$] op on il.SKU=op.SKU)", con, adOpenStatic, adLockOptimistic, adCmdText
If Not rs.EOF Then
Sheets("amazon result").Cells(2, 1).CopyFromRecordset rs
End If
rs.Close
Set rs = Nothing
Set rs = New ADODB.Recordset
''check stocks
rs.Open "SELECT ar.SKU, iif(isnull(ar.Quantity),0,ar.Quantity)+iif(isnull(hs.Quantity),0,hs.Quantity) " & _
"FROM ( [amazon result$] ar LEFT JOIN [holding stock$] hs on ar.SKU=hs.SKU)", _
con, adOpenKeyset, adLockOptimistic
i = 2
While Not rs.EOF
Sheets("amazon result").Cells(i, 1) = rs(0).Value
Sheets("amazon result").Cells(i, 2) = rs(1).Value
rs.MoveNext
i = i + 1
Wend
rs.Close
''ebay
rs.Open "SELECT * FROM [Amazon result$]", con, adOpenKeyset, adLockReadOnly
Set ws = Sheets("ebay upload")
LastRow = ws.Cells(65000, 11).End(xlUp).Row
For r = 2 To LastRow
If ws.Cells(r, 11).Value <> "" Then
rs.Filter = "SKU='" & ws.Cells(r, 11).Value & "'"
ws.Cells(r, 8).Value = rs(1)
End If
Next r
rs.Close
Set rs = Nothing 'killing here because it messes up the next query if you leave it open
Set rs = New ADODB.Recordset
''website
rs.Open "SELECT [field data 1], [field data 2], [field data 3], [field data 4], [field data 5], [field data 6], [field data 7], [field data 8], SKU, [field data 10], [field data 11], [field data 12] " & _
"FROM ([website upload$] wu LEFT JOIN [amazon result$] ar " & _
"ON wu.[field data 7]=ar.SKU)", _
con, adOpenKeyset, adLockReadOnly
If Not rs.EOF Then
Sheets("dump").Cells.Clear
Sheets("dump").Cells(1, 1).CopyFromRecordset rs
Sheets("website upload").Rows("2:65000").Clear
Sheets("dump").UsedRange.Copy Sheets("website upload").Cells(2, 1)
End If
rs.Close
GoTo cleanup
errorhandler:
MsgBox "There was an error." & vbCrLf & vbCrLf & Err.Description, vbCritical
cleanup:
If rs.State = adStateOpen Then rs.Close
If con.State = adStateOpen Then con.Close
Set rs = Nothing
Set con = Nothing
End Sub
Sub AddHeadersToAmazonResult()
Sheets("amazon result").Cells.ClearContents
Sheets("amazon result").Cells(1, 1) = "SKU"
Sheets("amazon result").Cells(1, 2) = "Quantity"
End Sub
答案 2 :(得分：0)
以下是一些编码建议 - 可能无法帮助提高速度，在尝试使用完整数据集之前无法判断。
使用Option Explicit，以便了解您是否正确使用变量
`roboCode'sub生成一些代码，使工作表引用更通用。运行一次以生成代码并将其复制到正确的位置 - 模块调用wks和子init（）。
使用工作表编号是一个非常糟糕的主意。 roboCode允许您通过名称进行寻址。
捕获错误。
不要在dim语句中使用一行 - 结果是对象/变体，而不是最后一个变量的类型。
对行计数/索引使用long。
尝试使用.Cells进行范围寻址。更容易编写代码，更清晰。
使用缩进 - 突出显示行并使用Tab和shift-Tab控制缩进
通过状态栏向外界通知进度，偶尔调用DoEvents以允许其他进程运行以及屏幕更新。你会看到这段代码随着它的进展而变慢（基于sample.xls） - 我认为Find是罪魁祸首。您可以考虑使用VB.Net解决方案而不是Excel VBA。访问可能会更好。
其他评论内联
Option Explicit
Sub roboCode()
' name worksheets
Dim i As Integer
Debug.Print "' global dim in module named 'wks'"
For i = 1 To ThisWorkbook.Worksheets.Count
Debug.Print "public wks" & Replace(ThisWorkbook.Worksheets(i).Name, " ", "_") & " as worksheet"
Next i
Debug.Print "' one time Set"
For i = 1 To ThisWorkbook.Worksheets.Count
Debug.Print "set wks" & Replace(ThisWorkbook.Worksheets(i).Name, " ", "_") & " = ThisWorkbook.Worksheets(""" & ThisWorkbook.Worksheets(i).Name & """)"
Next i
End Sub
Sub Init()
' text from roboCode
Set wks.Imported_list = ThisWorkbook.Worksheets("imported list")
Set wks.Amazon_result = ThisWorkbook.Worksheets("amazon result")
Set wks.Our_products = ThisWorkbook.Worksheets("Our products")
Set wks.Holding_stock = ThisWorkbook.Worksheets("holding stock")
Set wks.Ebay_upload = ThisWorkbook.Worksheets("ebay upload")
Set wks.Website_upload = ThisWorkbook.Worksheets("website upload")
Set wks.Personalised_Goods = ThisWorkbook.Worksheets("Personalised Goods")
Set wks.Manual_checks = ThisWorkbook.Worksheets("Manual checks")
End Sub
Function RowCount(wks As Worksheet) As Long
RowCount = wks.UsedRange.Rows.Count
End Function
Function ColCount(wks As Worksheet) As Long
ColCount = wks.UsedRange.Columns.Count
End Function
Sub Here()
On Error GoTo Local_error
Init
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Dim srchLen, srchLen2, srchLen4, srchLen5, gName, nxtRw As Integer ' all Objects/Variants except nxtRw
Dim srchLen As Long
Dim srchLen2 As Long
Dim srchLen4 As Long
Dim srchLen5 As Long
Dim srchLen6 As Long
Dim gName As Long
Dim rng As Range
Dim i As Long
Dim j As Long
Dim nxtRw As Long
'Clear Sheet 2 and Copy Column Headings
' wks.Ebay_upload.Cells.ClearContents
wks.Ebay_upload.UsedRange.Delete (xlUp)
'Determine length of Search Column from Sheet3
' srchLen = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row
srchLen = wks.Our_products.UsedRange.Rows.Count ' not used, RowCount() used instead
'Loop through list in Sheet3, Column A. As each value is
'found in Sheet1, Column A, copy it top the next row in Sheet2
With wks.Imported_list.Columns(1)
nxtRw = 1
For gName = 1 To RowCount(wks.Our_products)
' I think this next statement is slowing things down, may be unavoidable
Set rng = .Find(wks.Our_products.Cells(gName, 1))
If Not rng Is Nothing Then
nxtRw = nxtRw + 1
' copy may be slower than individual assigments
' rng.EntireRow.Copy Destination:=wks.Amazon_result.Rows(nxtRw)
wks.Amazon_result.Cells(nxtRw, 1) = rng.Value
If nxtRw Mod 100 = 0 Then
Application.StatusBar = nxtRw
DoEvents
End If
End If
Next
End With
' ....
Application.ScreenUpdating = True
MsgBox "Done"
Local_exit:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
Exit Sub
Local_error:
Application.ScreenUpdating = True
MsgBox Err & " " & Err.Description ' hit ctrl-break if you get here, then set next to Resume for debug
Resume Local_exit
Resume
End Sub
答案 3 :(得分：0)
基于提供的文件
Option Explicit
Public Sub HereArrays()
Dim lr1 As Long, lr2 As Long, lr3 As Long
Dim v1 As Variant, v2 As Variant, v3 As Variant
Dim i1 As Long, i2 As Long, i3 As Long, t As Double, t1 As Double
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
t = Timer: t1 = t
'Clear Sheet 2
Sheets(2).UsedRange.EntireColumn.Delete
lr1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
lr2 = lr1
lr3 = Sheets(3).Range("A" & Rows.Count).End(xlUp).Row
v1 = Sheets(1).Range("A1:B" & lr1)
v2 = Sheets(2).Range("A1:B" & lr1)
v3 = Sheets(3).Range("A1:B" & lr3)
i2 = 1
For i3 = 1 To lr3
For i1 = 1 To lr1
If v3(i3, 1) = v1(i1, 1) Then
v2(i2, 1) = v1(i1, 1)
v2(i2, 2) = v1(i1, 2)
i2 = i2 + 1
Exit For 'exit inner For only
End If
Next
Next
Sheets(2).Range("A1:B" & lr2) = v2
Debug.Print "HereArrays - 1 of 4 - Duration: " & Timer - t & " seconds"
t = Timer
' stage 2 Check my Local Stocks
lr1 = Sheets(4).Range("A" & Rows.Count).End(xlUp).Row
lr2 = Sheets(2).Range("A" & Rows.Count).End(xlUp).Row
v1 = Sheets(4).Range("A1:B" & lr1)
v2 = Sheets(2).Range("A1:B" & lr2)
For i1 = 1 To lr1
For i2 = 1 To lr2
If v1(i1, 1) = v2(i2, 1) Then
v2(i2, 2) = v2(i2, 2) + v1(i1, 2)
Exit For 'exit inner For only
End If
Next
Next
Sheets(2).Range("A1:B" & lr2) = v2
Debug.Print "HereArrays - 2 of 4 - Duration: " & Timer - t & " seconds"
t = Timer
'EBAY CODE
lr1 = Sheets(5).Range("K" & Rows.Count).End(xlUp).Row
v1 = Sheets(5).Range("K1:K" & lr1)
v3 = Sheets(5).Range("H1:H" & lr1)
v2 = Sheets(2).Range("A1:B" & lr2)
For i2 = 1 To lr2
For i1 = 1 To lr1
If Len(v1(i1, 1)) = 0 Then i1 = i1 + 1
If v2(i2, 1) = v1(i1, 1) Then
v3(i1, 1) = v2(i2, 2)
Exit For 'exit inner For only
End If
Next
Next
Sheets(5).Range("H1:H" & lr1) = v3
Debug.Print "HereArrays - 3 of 4 - Duration: " & Timer - t & " seconds"
t = Timer
'website CODE
lr1 = Sheets(6).Range("G" & Rows.Count).End(xlUp).Row
v1 = Sheets(6).Range("G1:G" & lr1)
v3 = Sheets(6).Range("I1:I" & lr1)
v2 = Sheets(2).Range("A1:B" & lr2)
For i2 = 1 To lr2
For i1 = 1 To lr1
If Len(v1(i1, 1)) = 0 Then i1 = i1 + 1
If v2(i2, 1) = v1(i1, 1) Then
v3(i1, 1) = v2(i2, 2)
Exit For 'exit inner For only
End If
Next
Next
Sheets(6).Range("I1:I" & lr1) = v3
Debug.Print "HereArrays - 4 of 4 - Duration: " & Timer - t & " seconds"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Call Calculate
Debug.Print "HereArrays - Total - Duration: " & Timer - t1 & " seconds"
'HereArrays - 1 of 4 - Duration: 86.2109375 seconds
'HereArrays - 2 of 4 - Duration: 0.328125 seconds
'HereArrays - 3 of 4 - Duration: 0.25 seconds
'HereArrays - 4 of 4 - Duration: 16.47265625 seconds
'HereArrays - Total - Duration: 103.26171875 seconds
End Sub
基本上，这是初始代码“翻译”使用数组而不是与Ranges交互
详细测量
发布代码：
'Here - 1 of 4 - Duration: 654.28515625 seconds
'Here - 2 of 4 - Duration: 24.5078125 seconds
'Here - 3 of 4 - Duration: 13.43359375 seconds
'Here - 4 of 4 - Duration: 1195.375 seconds
'Here - Total - Duration: 1887.6015625 seconds
此代码：
'HereArrays - 1 of 4 - Duration: 86.2109375 seconds
'HereArrays - 2 of 4 - Duration: 0.328125 seconds
'HereArrays - 3 of 4 - Duration: 0.25 seconds
'HereArrays - 4 of 4 - Duration: 16.47265625 seconds
'HereArrays - Total - Duration: 103.26171875 seconds