在VBA中搜索期间无响应状态

我的要求最终略有变化。质量保证负责人希望在原始工作表中使用元数据，因此我可以使用完整的场景列表，而不必查看原始数据中的每一行。结果，我可以将场景列表保存并排序到数组中，然后执行.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