在VBAsearch期间没有响应状态
我正在创build一个工作簿，将根据列中的值将数据从源工作表复制并粘贴到多个其他工作表中。 但是，一旦我启动macros，Excel进入一个不响应的状态。 我在4000到500000行的任何地方操作，但只有4列。 当我只有4000行时，它工作得很快（3秒）。 当我有〜30,000行时，Excel进入一个不响应的状态约10秒钟，然后结束。 我没有等待30万行的testing。
我这样做的思想过程就是根据B列中的string对所有数据进行sorting，将列B （包含我正在search的string）的所有列都放入数组中，然后将所有的唯一string另一个arrays。 例如，如果列B在行1-200中保持“search”，并且在行201-500中“创build”，macros将search行和第二个数组（将其称为场景）将最终保持两个值， “search”和“创build”。
在search过程中，我还创build了两个平行数组，它们与Scenario数组对应，该数组将保存该场景的开始和结束行。 之后，我只需循环并行数组中的值，并从源工作表复制/粘贴到其他工作表。
注：sorting工作正常
有没有办法让这个更快？
这是代码：分配数据
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
GetScenarioList
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
这将对未sorting的数据起作用，但如果先sorting，速度会更快。
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
在我看来，复制粘贴是在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
哦，我已经改变了scenariorange是一个范围variables，在我看来很容易使用。 像这样使用它：
Dim ScenarioRange as Range Set ScenarioRange = Range("A" & parallelScenarioStart(intPosition) & ":" & "D" & parallelScenarioEnd(intPosition))
希望这可以加快速度。 （我希望你能理解我在这里想说的话，我有点困… :)）
另外，closures屏幕更新通常会加快程序的速度。
application.screenupdating=false
不要忘记在代码结尾处重新开启它！
我的要求最终略有改变。 质量保证主pipe希望在原始工作表中使用元数据，因此我可以使用完整的scheme列表，而不必查看原始数据中的每一行。 因此，我可以将场景列表保存并sorting为数组，然后执行.Find（parallelScenarioName（intPosition + 1））。行以获取下一个场景的行。
由于这个变化，我没有完全实现并testingTim Williams解决scheme，它将遍历数据中的每一行。 我现在必须继续前进，但很快就会重新审视和testingTim的解决scheme。
完成的代码如下。
'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