Vb.net 如何加快这段代码的运行速度，但速度非常慢？

我有这段代码，但在后面的过程中运行得太慢：

    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是我们经销商的库存清单，其中包含约65k项columnA=SKU ColumnB=数量

第2页是一个结果页，其中第3页与第1页进行比较，如果存在，则将其打印到第2页，然后行行将以某种循环方式递增到下一行

表1、2、3运行得很好，但在计算过去的“第2阶段检查我的本地股票”时，整个宏观经济放缓

易趣和网站代码似乎减慢了一切，可能是因为下一个循环的原因

我已经在我们的Web服务器上上传了一个小版本的。请在运行之前对其进行病毒扫描

---

将此代码复制粘贴到宏中，您应该很容易理解它的作用以及我试图实现的目标。它可以满足我的需求，但速度太慢。

总体建议：

在过程开始时，将Excel范围转换为数组。花费如此多时间的部分原因是Excel一次访问一个单元格，这比访问内部范围数据花费的时间更长

例如，在您的过程开始时，创建一个名为“Website_Stock”的对象类，包含您关心的索引、名称、数量等所有属性，然后为每个网站的股票定义一个数组。然后，正如你已经做的那样，计算第一行和最后一行，正如你上面所做的那样，但然后说一些大致如下的话：

Redim Website_Stock(1 to lastrow)
Set  Website_Stock_Range to Range(Firstcolumn & firstrow, Lastcolumn & lastrow)

然后根据新创建的范围指定数组中的所有属性。比如：

For i = 1 to lastrow
    Website_Stock(i).Index = Website_Stock_Range(x, y)
Next i

*这只是伪代码

---

然后在创建结束时，您可以像上面一样使用For循环，并且它不需要每次访问Excel工作表进行更改。

使用ADO查询工作表而不是循环将节省大量时间，我进行了这些更改并粘贴了下面的代码以运行。我想它正是你想要的

1将标题SKU、数量添加到导入列表

2将标题SKU、数量添加到亚马逊结果

3将标题SKU添加到我们的产品中

4更改网站上载中的标题，以对其进行编号，而不是对所有字段数据进行编号1

4添加名为dump的工作表

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

---

以下是一些编码建议-可能对速度没有帮助，除非您尝试使用完整的数据集，否则无法判断

使用Option Explicit，以便知道是否正确使用了变量

`“机器人代码”子系统生成一些代码，使图纸参考更通用。运行它一次以生成代码并将其复制到适当的位置—模块调用wks和子初始化

使用工作表编号是一个非常糟糕的主意。roboCode将允许您通过名称进行地址设置

捕捉你的错误

请勿将一行用于dim语句-结果对象/变量，而不是最后一个变量的类型

对行计数/索引使用long

尝试使用.Cells进行范围寻址。更容易编写代码，更清晰

使用缩进-高亮显示行，并使用Tab和shift选项卡控制缩进

通过状态栏向外部通知进度，偶尔调用DoEvents以允许其他进程运行并更新屏幕。您将看到这段代码在基于sample.xls的过程中变得越来越慢，我认为这是罪魁祸首。您可以考虑用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

---

根据提供的文件

张贴代码：约32分钟 此解决方案：大约2分钟 基本上，这是转换为使用数组而不是与范围交互的初始代码

详细测量

张贴代码：

'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

---

这听起来像是一个愚蠢的问题，但是是否有任何格式化的单元，即字体，如表等等？考虑把这个问题移到CoDeEvIEW.StAccExchange。com -它们只处理当前正在运行的代码的改进；但这并不意味着你不能在这里寻求帮助。而且你的行数应该是长的而不是变量尝试了这段代码，首先运行了roboCode，但在运行init时，我得到了一个变量未定义的错误。当我有更多的时间时，我会再看一遍，但谢谢你的投入。

'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