Question

提前感谢您的协助。

我正在运行一个宏，我在工作表中有一个唯一记录列表＆＃34; Sheet2＆＃34;它将在工作表＆＃34; PO_Details＆＃34;中搜索这些条目。一旦找到细节，它就会在＆＃34; Sheet2＆＃34;中添加这些字段。并追加价值观。所以结果可能是这样的：

A; B; C等取决于PO详细信息中的记录数

我的PO_details表有8700条记录

我的Sheet2有6700条独特记录

宏工作正常但唯一的问题是当我运行此代码时，运行大约需要10分钟。我担心当独特记录增加到更高的数字时，性能会降低。

我需要做些什么才能优化此代码

我是初学者，非常感谢任何帮助：）

Sub Macro3()

    ' Keyboard Shortcut: Ctrl+u

    Dim PO_Name As String
    Dim Finalrow As Integer
    Dim i As Integer
    Dim fValue As String
    Dim Tmp As String
    Dim x As Integer
    Dim fValue1 As String
    Dim Tmp1 As String
    Dim fValue2 As String
    Dim Tmp2 As String
    Dim fValue3 As String
    Dim Tmp3 As String

    Sheets("Sheet2").Range("b2:f20000").ClearContents

    Finalrow = Sheets("PO_Details").Range("H30000").End(xlUp).Row
    Finalrow_unique = Sheets("Sheet2").Range("a30000").End(xlUp).Row

    For x = 2 To Finalrow_unique
        PO_Name = Sheets("Sheet2").Range("a" & x).Value

        fValue = " "
        fValue1 = " "
        fValue2 = " "
        fValue3 = " "

        For i = 2 To Finalrow

            If Sheets("PO_Details").Range("h" & i) = PO_Name Then

                'Cells(i, 1) = PO_Name Then
                Tmp = Sheets("PO_Details").Range("c" & i).Value
                fValue = fValue & ";" & Tmp
                Tmp1 = Sheets("PO_Details").Range("d" & i).Value
                fValue1 = fValue1 & ";" & Tmp1
                Tmp2 = Sheets("PO_Details").Range("b" & i).Value
                fValue2 = fValue2 & ";" & Tmp2
                Tmp3 = Sheets("PO_Details").Range("e" & i).Value
                fValue3 = fValue3 & ";" & Tmp3

            End If
        Next i

        Sheets("sheet2").Range("b" & x) = fValue
        Sheets("sheet2").Range("c" & x) = fValue1
        Sheets("sheet2").Range("d" & x) = fValue2
        Sheets("sheet2").Range("e" & x) = fValue3

    Next x

End Sub

Answer 1

代码有两个主要的性能问题：

一次从电子表格中读取数据。每次从Excel获取数据以在VBA中使用或将数据从VBA写入单元时，都会产生处理开销。在VBA中将整个范围读入单个数组变量，然后循环遍历该数组的速度要快许多倍。
它循环遍历PODetails中sheet2中每一行的所有行。这是最慢和最重复的搜索。有很多方法可以提高效率。

这是伪代码中的一种可能方法。我们的想法是只在PODetails上循环一次。随时构建和复制值。在很多方面，这仍然可以提高效率，但这仍然是一个非常简单的方法，仍然可以获得巨大的改进。

Sort both lists in ascending order by PO_Name
Read all data from PO_Details into a single array variable PODetails
From PODetails, Set CurrentPOName = first PO_Name
Set CurrentfValue = first fValue 
Set CurrentfValue1 = first fValue1
Set CurrentfValue2 = first fValue2 
Set CurrentfValue3 = first fValue3 
Set UniquePORowCounter = 1
For PODetailsRowCounter = 2 to PODetails.Rows
    If PODetails(PODetailsRowCounter).POName = CurrentPOName Then
        Append fValue into CurrentfValue
        Append fValue1 into CurrentfValue1
        Append fValue2 into CurrentfValue2
        Append fValue3 into CurrentfValue3
    Else
        Use fast double vlookup to find the row on which CurrentPOName exists in UniquePO
        If CurrentPOName is found, then save fValues onto UniquePO sheet (if not found, then ignore and continue)
        Set CurrentPOName = PODetailsRow(PODetailsRowCounter).POName
        Set CurrentfValue = PODetailsRow(PODetailsRowCounter).CurrentfValue
        Set CurrentfValue1 = PODetailsRow(PODetailsRowCounter).CurrentfValue1
        Set CurrentfValue2 = PODetailsRow(PODetailsRowCounter).CurrentfValue2
        Set CurrentfValue3 = PODetailsRow(PODetailsRowCounter).CurrentfValue3
    End If
Next PODetailsRowCounter

Answer 2

这里是你的代码被重写为使用数组...未经测试

Sub Macro3()
    '
    ' Macro3 Macro
    '
    ' Keyboard Shortcut: Ctrl+u
    '
    Dim PO_Name As String
    Dim Finalrow As Long          ' use long here. you may go past 32k rows in the future
    Dim Finalrow_unique As Long

    Dim i As Integer
    Dim x As Integer

    Dim fValue1 As String   ' changed names here so that everything lines up
    Dim fValue2 As String
    Dim fValue3 As String
    Dim fValue4 As String


    Sheets("Sheet2").Range("b2:f20000").ClearContents

    Finalrow = Sheets("PO_Details").Range("H30000").End(xlUp).Row
    Finalrow_unique = Sheets("Sheet2").Range("a30000").End(xlUp).Row

    Dim colB As Variant
    Dim colC As Variant
    Dim colD As Variant
    Dim colE As Variant
    Dim colH As Variant

    colB = Sheets("PO_Details").Range("b1:b" & Finalrow) ' pull data from the five ranges into arrays
    colC = Sheets("PO_Details").Range("c1:c" & Finalrow)
    colD = Sheets("PO_Details").Range("d1:d" & Finalrow) ' start at first row
    colE = Sheets("PO_Details").Range("e1:e" & Finalrow) ' so that the loop in the code below
    colH = Sheets("PO_Details").Range("h1:h" & Finalrow) ' can start at 2 as before


    For x = 2 To Finalrow_unique

        fValue1 = " "
        fValue2 = " "
        fValue3 = " "
        fValue4 = " "

        PO_Name = Sheets("Sheet2").Range("a" & x).Value

        For i = 2 To Finalrow
            If colH(i, 1) = PO_Name Then
                fValue1 = fValue1 & ";" & colC(i, 1) ' the range actually is a 2D array
                fValue2 = fValue2 & ";" & colD(i, 1)
                fValue3 = fValue3 & ";" & colB(i, 1)
                fValue4 = fValue4 & ";" & colE(i, 1)
            End If
        Next i

        Sheets("sheet2").Range("b" & x) = fValue1
        Sheets("sheet2").Range("c" & x) = fValue2
        Sheets("sheet2").Range("d" & x) = fValue3
        Sheets("sheet2").Range("e" & x) = fValue4

    Next x

End Sub

Answer 3

使用数组而不是通过范围循环，您可以始终加速。我添加了一个计时器来检查这个。此示例允许在数据字段数组中执行所有字符串组合，其中包含一个中的所有必要数据，并在一个代码行中再次将其写回，而不是循环遍历范围：

<强>代码

Option Explicit Sub Macro3a() ' ' Macro3 Macro ' ' Keyboard Shortcut: Ctrl+u ' Dim v, v2 ' Variant Dim ws As Worksheet Dim ws2 As Worksheet Dim t As Double Dim PO_Name As String Dim Finalrow As Long Dim Finalrow_unique As Long Dim i As Long Dim x As Long Dim fValue As String Dim fValue1 As String Dim fValue2 As String Dim fValue3 As String ' stop watch t = Timer ' set worksheets to memory Set ws = ThisWorkbook.Worksheets("PO_Details") ' details Set ws2 = ThisWorkbook.Worksheets("Sheet2") ' target sheet with unique values ' clear contents in target sheet ws2.Range("B:F").ClearContents ' define last rows Finalrow = ws.Range("H" & ws.Rows.Count).End(xlUp).Row Finalrow_unique = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row ' get values to one based 2dim arrays v = ws.Range("A1:H" & Finalrow).Value v2 = ws2.Range("A1:E" & Finalrow_unique).Value ' loop thru unique values For x = 2 To Finalrow_unique PO_Name = v2(x, 1) fValue = " " fValue1 = " " fValue2 = " " fValue3 = " " ' get string values For i = 2 To Finalrow If v(i, 8) = PO_Name Then fValue = fValue & ";" & v(i, 3) fValue1 = fValue1 & ";" & v(i, 4) fValue2 = fValue2 & ";" & v(i, 2) fValue3 = fValue3 & ";" & v(i, 5) End If Next i ' fill in target columns B:E in sheet2 (column A remains unchanged) v2(x, 2) = fValue v2(x, 3) = fValue1 v2(x, 4) = fValue2 v2(x, 5) = fValue3 Next x ' write array v2 back to sheet2 ws2.Range("A1:E" & Finalrow_unique).Value = v2 Debug.Print "Time needed: " & Format(Timer - t, "0.00") & " seconds." End Sub

注意

上述代码中的所有fValue变量都保持不变。为了使代码更具可读性，我建议您根据列字母重命名代码，例如： fColD而不是fValue2或fColE而不是fValue3。此外，您可以尝试使用Type定义，确定您可以在SO找到一些东西。

Answer 4

如前面的答案中所述，您可以通过不通过VBA表PO_Details循环来加速代码。

即。您可以使用内置函数Find来搜索PO_Details中的相应行。

Sub Macro3()
'
' Macro3 Macro
'
' Keyboard Shortcut: Ctrl+u
'
Dim PO_Name As String
Dim Finalrow As Integer
Dim Finalrow_unique As Integer
Dim i As Integer
Dim fValue As String
Dim Tmp As String
Dim x As Integer
Dim fValue1 As String
Dim Tmp1 As String
Dim fValue2 As String
Dim Tmp2 As String
Dim fValue3 As String
Dim Tmp3 As String
Dim search_value As String

Sheets("Sheet2").Range("b2:f20000").ClearContents

Finalrow = Sheets("PO_Details").Range("H30000").End(xlUp).Row
Finalrow_unique = Sheets("Sheet2").Range("a30000").End(xlUp).Row

For x = 2 To Finalrow_unique
    PO_Name = Sheets("Sheet2").Range("a" & x).Value

    fValue = " "
    fValue1 = " "
    fValue2 = " "
    fValue3 = " "

    Dim c As Range
    With Sheets("PO_Details").Range("h1:h30000")
        Set c = .Find(PO_Name, LookIn:=xlValues)
        If Not c Is Nothing Then
            i = c.Row
            Tmp = Sheets("PO_Details").Range("c" & i).Value
            fValue = fValue & ";" & Tmp
            Tmp1 = Sheets("PO_Details").Range("d" & i).Value
            fValue1 = fValue1 & ";" & Tmp1
            Tmp2 = Sheets("PO_Details").Range("b" & i).Value
            fValue2 = fValue2 & ";" & Tmp2
            Tmp3 = Sheets("PO_Details").Range("e" & i).Value
            fValue3 = fValue3 & ";" & Tmp3
        End If
    End With

    Sheets("sheet2").Range("b" & x) = fValue
    Sheets("sheet2").Range("c" & x) = fValue1
    Sheets("sheet2").Range("d" & x) = fValue2
    Sheets("sheet2").Range("e" & x) = fValue3
Next x

End Sub

这个宏代码可以优化吗？

4 个答案: