在 VBA 中搜索期间没有响应状态

Question

我正在创建一个工作簿，它将根据列中的值将数据从源工作表复制并粘贴到多个其他工作表。但是，一旦我启动宏，Excel 就会进入无响应状态。我在 4000 到 500,000 行的任何地方进行操作，但只有 4 列。当我只有约 4000 行时，它的运行速度非常快（3 秒）。当我有约 30,000 行时，Excel 进入无响应状态约 10 秒，但随后完成。 300,000 行测试我没有等待足够长的时间。

我的想法是根据B 列中的字符串对所有数据进行排序，将所有B 列（包含我正在搜索的字符串）放入一个数组中，然后拉所有唯一的字符串输出到另一个数组中。例如，如果列B 在第 1-200 行中包含“搜索”，在第 201-500 行中包含“创建”，则宏将搜索行，第二个数组（我们称之为场景）最终将包含两个值，“搜索”和“创建”。

在搜索过程中，我还创建了两个与场景数组对应的并行数组，该数组将保存该场景的开始行和结束行。之后，我将遍历并行数组中的值，然后从源工作表复制/粘贴到其他工作表。

注意：排序工作正常

有没有办法让它更快？

代码如下： 分配数据

Sub AllocateData()

Dim scenarioRange As String             'To hold the composite range
Dim parallelScenarioName() As String    'Holds the unique scenario names
Dim parallelScenarioStart() As Long     'Holds the starting row of the scenario
Dim parallelScenarioEnd() As Long       'Holds the ending row of the scenario

Sheets("raw").Activate                  'Raw is the source worksheet

'Populates the parallel scenario arrays
Call GetScenarioList(parallelScenarioName, parallelScenarioStart, parallelScenarioEnd)

'Loops through the scenario parallel array and coes the copy and paste to other worksheets
'Workseets are named the same as the scenarios
For intPosition = LBound(parallelScenarioName) To (UBound(parallelScenarioName) - 1)
    scenarioRange = "A" & parallelScenarioStart(intPosition) & ":" & "D" & parallelScenarioEnd(intPosition)
    Range(scenarioRange).Select
    Selection.Copy

    Worksheets(parallelScenarioName(intPosition)).Activate

    Range("A1").Select
    ActiveSheet.Paste
    Sheets("raw").Activate
Next

End Sub

获取场景列表

Sub GetScenarioList(ByRef parallelScenarioName() As String, ByRef parallelScenarioStart() As Long, ByRef parallelScenarioEnd() As Long)
Dim scenarioName As Variant
Dim TotalRows As Long
Dim arraySize As Long
arraySize = 1

'Prep the parallel array for scenario name with the first value
ReDim parallelScenarioStart(1)
ReDim parallelScenarioName(1)
parallelScenarioStart(0) = 1                'First spot on the scenario start will be row 1

'Prep the first scenario name
'Sometimes a number will be attached on the end of the scenario name delimited by a period. Ignore it.
If (InStr(Cells(1, 2).Text, ".") <> 0) Then
    parallelScenarioName(0) = Left(Cells(1, 2).Text, InStr(Cells(1, 2).Text, ".") - 1)
Else
    parallelScenarioName(0) = Cells(1, 2).Text
End If

'Get the total amount of rows
TotalRows = Rows(Rows.Count).End(xlUp).row

'Loop through all of the rows
For i = 1 To TotalRows
    'Sometimes a number will be attached on the end of the scenario name delimited by a period. Ignore it.
    If (InStr(Cells(i, 2).Text, ".") <> 0) Then
        scenarioName = Left(Cells(i, 2).Text, InStr(Cells(i, 2).Text, ".") - 1)
    Else
        scenarioName = Cells(i, 2).Text
    End If

    'If the scenario name is not contained in the unique array
    If IsNotInArray(scenarioName, parallelScenarioName) Then
        Call AddScenarioEndRow(i, arraySize, parallelScenarioEnd)
        Call AddNewScenarioToParallelArray(scenarioName, arraySize, parallelScenarioName)
        Call AddNewScenarioStartRow(i, arraySize, parallelScenarioStart)
    End If
Next

'Cleanup. The above code did not cover the ending row of the last scenario
Call AddScenarioEndRow(TotalRows + 1, arraySize, parallelScenarioEnd)

End Sub

IsNotInArray

Function IsNotInArray(stringToBeFound As Variant, ByRef parallelScenarioName() As String) As Boolean
  IsNotInArray = Not (UBound(Filter(parallelScenarioName, stringToBeFound)) > -1)
End Function

并行数组

Sub AddNewScenarioToParallelArray(str As Variant, arraySize As Long, ByRef parallelScenarioName() As String)
arraySize = UBound(parallelScenarioName) + 1
ReDim Preserve parallelScenarioName(arraySize)
parallelScenarioName(arraySize - 1) = str
End Sub

Sub AddScenarioEndRow(row As Variant, ByRef arraySize As Long, ByRef parallelScenarioEnd() As Long)
ReDim Preserve parallelScenarioEnd(arraySize)
parallelScenarioEnd(arraySize - 1) = row - 1
End Sub

Sub AddNewScenarioStartRow(row As Variant, ByRef arraySize As Long, ByRef parallelScenarioStart() As Long)
ReDim Preserve parallelScenarioStart(arraySize)
parallelScenarioStart(arraySize - 1) = row
End Sub

Answer 1

这适用于未排序的数据，但如果先排序会更快。

Sub AllocateData()

    Dim shtRaw As Worksheet, currVal, rng As Range
    Dim c As Range, rngCopy As Range, i As Long, tmp

    Set shtRaw = Sheets("raw")

    On Error GoTo haveError

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set rng = shtRaw.Range(shtRaw.Range("B1"), _
                           shtRaw.Cells(Rows.Count, "B").End(xlUp))

    currVal = "~~~~~~~~~~~~~~~" 'or any non-value

    For Each c In rng.Cells
        tmp = c.Value
        If tmp <> currVal Then
            If Not rngCopy Is Nothing Then
                rngCopy.Copy Sheets(currVal).Cells(Rows.Count, _
                                       "A").End(xlUp).Offset(1, 0)
            End If
            Set rngCopy = c.Offset(0, -1).Resize(1, 4)
            currVal = tmp
            i = 1
        Else
            i = i + 1
            Set rngCopy = rngCopy.Resize(i, 4)
        End If
    Next c

    If Not rng Is Nothing Then
        rngCopy.Copy Sheets(currVal).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
    End If

haveError:
    'must reset calculation, or it will remain on "manual"
    Application.Calculation = xlCalculationAutomatic

    'ScreenUpdating will auto-reset once the sub exits,
    '   but I think it's good practise to explicitly reset it
    Application.ScreenUpdating = True

End Sub

Answer 2

根据我的经验，复制粘贴是您在 VBA 中可以做的最慢的事情。 尝试简单地将范围 1 的值分配给范围 2，有点像这样：

range("b1:b4").value=range("a1:a4").value

确保范围大小相同。

在您的 AllocateData 子中，您可以使用以下内容：

Worksheets(parallelScenarioName(intPosition)).activate
Range(cells(1,1),cells(scenariorange.rows.count,1).value=scenariorange.value
Sheets("raw").Activate

哦，我已将场景范围更改为范围变量，在我看来更易于使用。像这样使用它：

Dim ScenarioRange as Range
Set ScenarioRange = Range("A" & parallelScenarioStart(intPosition) & ":" & "D" & parallelScenarioEnd(intPosition))

希望这能加快速度。 （而且我希望你能明白我在这里想说什么，我有点困...... :)）

另外，关闭屏幕更新通常会大大加快程序速度。

application.screenupdating=false

不要忘记在代码末尾重新打开它！

Answer 3

我的要求最终略有变化。 QA 负责人想要原始工作表中的元数据，因此我可以使用完整的方案列表，而不必查看原始数据中的每一行。结果，我可以将场景列表保存并排序到一个数组中，然后执行 .Find(parallelScenarioName(intPosition + 1)).row 来获取下一个场景的行。

由于此更改，我没有完全实现和测试 Tim Williams 解决方案，该解决方案将遍历数据中的每一行。我现在必须继续前进，但我很快会根据自己的知识重新审视和测试 Tim 的解决方案。

完成的代码如下。

'This is in a module so that my subs can see it
Option Explicit
Public Const DATASOURCE_WORKSHEET As String = "raw"

'This is the macro is called. Can be considered main.
Sub AllocateImportedData()
    Call SortDataSourceWorksheet
    Call AllocateData
End Sub

Sub SortDataSourceWorksheet()
    Dim entireRangeToSort As String
    Dim colToSortUpon As String
    Dim lastRow As Long

    lastRow = FindLastRowOfRawData
    entireRangeToSort = ConstructRangeString("A", 1, "D", lastRow)
    colToSortUpon = ConstructRangeString("B", 1, "B", lastRow)

    Call SortRangeByColumnAtoZ(entireRangeToSort, colToSortUpon)
End Sub

Sub SortRangeByColumnAtoZ(entireRangeToSort As String, colToSortUpon As String)

    ActiveWorkbook.Worksheets(DATASOURCE_WORKSHEET).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(DATASOURCE_WORKSHEET).Sort.SortFields.Add Key:=Range(colToSortUpon), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(DATASOURCE_WORKSHEET).Sort
    .SetRange Range(entireRangeToSort)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With  
End Sub


Sub AllocateData()

    Dim scenarioRange As String             'To hold the composite range
    Dim parallelScenarioName() As String    'Holds the unique scenario names
    Dim parallelScenarioStart() As Long     'Holds the starting row of the scenario
    Dim parallelScenarioEnd() As Long       'Holds the ending row of the scenario

    Sheets(DATASOURCE_WORKSHEET).Activate

    Call PopulateParallelScenarioArrays(parallelScenarioName, parallelScenarioStart, parallelScenarioEnd)
    Call PerformAllocation(parallelScenarioName, parallelScenarioStart, parallelScenarioEnd)
    Call FinishByActivatingDesiredWorksheet(DATASOURCE_WORKSHEET)  
End Sub

Sub PerformAllocation(ByRef parallelScenarioName() As String, ByRef parallelScenarioStart() As Long, ByRef parallelScenarioEnd() As Long)

    For intPosition = LBound(parallelScenarioName) To (UBound(parallelScenarioName) - 1)
        scenarioRange = ConstructRangeString("A", parallelScenarioStart(intPosition), "D", parallelScenarioEnd(intPosition))
        Range(scenarioRange).Select
        Selection.Copy

        Worksheets(parallelScenarioName(intPosition)).Activate

        Range("A1").Select
        ActiveSheet.Paste
        Sheets(DATASOURCE_WORKSHEET).Activate
    Next 
End Sub

Sub PopulateParallelScenarioArrays(ByRef parallelScenarioName() As String, ByRef parallelScenarioStart() As Long, ByRef parallelScenarioEnd() As Long)
    Dim numberOfScenarios As Long

    numberOfScenarios = GetScenarioListFromRaw(parallelScenarioName)
    ReDim parallelScenarioStart(numberOfScenarios)
    ReDim parallelScenarioEnd(numberOfScenarios)
    Call GetStartAndEndRows(parallelScenarioName, parallelScenarioStart, parallelScenarioEnd)   
End Sub

Function GetScenarioListFromRaw(ByRef parallelScenarioName() As String) As Long

    Dim numberOfScenarios As Long
    Dim scenarioRange As String
    Const scenarioListStartColumn As String = "F"
    Const scenarioListStartRow As Long = "3"

    numberOfScenarios = GetNumberOfScenarios(scenarioListStartColumn, scenarioListStartRow)

    ReDim parallelScenarioName(numberOfScenarios)

    'Populate parallel scenario name
    For i = 0 To (numberOfScenarios - 1)
        scenarioRange = scenarioListStartColumn & (scenarioListStartRow + i)
        parallelScenarioName(i) = Range(scenarioRange).Text
    Next

    Call AtoZBubbleSort(parallelScenarioName)

    GetScenarioListFromRaw = numberOfScenarios

End Function

Function GetNumberOfScenarios(scenarioListStartColumn As String, scenarioListStartRow As Long)
    GetNumberOfScenarios = Range(scenarioListStartColumn & scenarioListStartRow, Range(scenarioListStartColumn & scenarioListStartRow).End(xlDown)).Rows.Count
End Function


Sub GetStartAndEndRows(ByRef parallelScenarioName() As String, ByRef parallelScenarioStart() As Long, ByRef parallelScenarioEnd() As Long)
    Dim TotalRows As Long
    Dim newScenarioRow As Long

    'Prep the parallel array for scenario name with the first value
    parallelScenarioStart(0) = 1                'First spot on the scenario start will be row 1

    'Get the total amount of rows
    TotalRows = Rows(Rows.Count).End(xlUp).row

    For intPosition = LBound(parallelScenarioName) To (UBound(parallelScenarioName) - 1)
        'Find the row of the next scenario
        newScenarioRow = Worksheets(DATASOURCE_WORKSHEET).Columns(2).Find(parallelScenarioName(intPosition + 1)).row

        'Next scenario row - 1 is going to be the end of the current row
        parallelScenarioEnd(intPosition) = newScenarioRow - 1

        'Set starting row of next scenario
        parallelScenarioStart(intPosition + 1) = newScenarioRow
    Next   
End Sub

Sub FinishByActivatingDesiredWorksheet(desiredWorksheet As String)
    Sheets(desiredWorksheet).Activate
    Range("A1").Select
End Sub

Sub AtoZBubbleSort(ByRef parallelScenarioName() As String)

    Dim s1 As String, s2 As String
    Dim i As Long, j As Long

    For i = LBound(parallelScenarioName) To UBound(parallelScenarioName)
        For j = i To UBound(parallelScenarioName)
            If UCase(parallelScenarioName(j)) < UCase(parallelScenarioName(i)) Then
                s1 = parallelScenarioName(j)
                s2 = parallelScenarioName(i)
                parallelScenarioName(i) = s2
                parallelScenarioName(j) = s1
            End If
        Next
    Next
End Sub

Sub ClearWorkbookCells()
    Dim anyWS As Worksheet

    For Each anyWS In ThisWorkbook.Worksheets
        Call ClearWorksheetCells(anyWS)
    Next    
End Sub

Sub ClearWorksheetCells(ws As Worksheet)
    ws.Activate

    ' Find the last row and create range var
    lastRow = FindLastRowOfRawData
    ClearRange = "A1:" & "D" & lastRow

    'Select the area to clear and perform clear
    ActiveSheet.Range(ClearRange).Select
    Selection.ClearContents
End Sub

Function FindLastRowOfRawData()
    FindLastRowOfRawData = Range("A1").End(xlDown).row
End Function

Function ConstructRangeString(startCol As String, startRow As Long, endCol As String, endRow As Long) As String
    ConstructRangeString = startCol & startRow & ":" & endCol & endRow
End Function