Not responding state during search in VBA - arrays

Question

I am creating a workbook that will copy and paste data from a source worksheet to multiple other worksheets depending upon values in a column. However, once I start the macro, Excel enters a not responding state. I am operating on anywhere from 4000 to 500,000 rows, but only 4 columns. When I only have ~4000 rows, it works pretty fast (3 seconds). When I have ~30,000 rows, Excel enters a not responding state for ~10 seconds, but then finishes. I didn't wait long enough for the 300,000 row test.
My thought process to do this would be to sort all of the data based upon the strings in column B, put all of column B (which contains the strings I am searching though) into an array, then pull all of the unique strings out into another array. For example, if column B held "Search" in rows 1-200, and "Create" in rows 201-500, the macro will search through the rows and the second array (lets call it Scenario) would end up holding two values, "Search" and "Create".
During the searching, I also created two parallel arrays that correspond with the Scenario array which would hold the beginning and ending rows for that scenario. After that, I would just loop through the values in the parallel arrays and copy/paste from the source worksheet to the other worksheets.
NOTE: The sort works fine
Is there a way to make this faster?
Here is the code:
Allocate Data
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
Parallel Arrays
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

This will work on unsorted data, but will be much faster if you sort first.
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

Copy-paste is, in my expreience, the slowest thing you can do in VBA.
Try simply assigning the values of range 1 to range 2, kinda like this:
range("b1:b4").value=range("a1:a4").value
Make sure the ranges are of the same size.
In your AllocateData sub, you could use something like:
Worksheets(parallelScenarioName(intPosition)).activate
Range(cells(1,1),cells(scenariorange.rows.count,1).value=scenariorange.value
Sheets("raw").Activate
Oh, I have changed scenariorange to be a range variable, lot easier to use in my opinion. Use it like this:
Dim ScenarioRange as Range
Set ScenarioRange = Range("A" & parallelScenarioStart(intPosition) & ":" & "D" & parallelScenarioEnd(intPosition))
Hope this speeds things up. (And I hope you can understand what I'm trying to say here, I'm a bit sleepy... :) )
Also, turning off the screenupdating usually speeds up the program a lot.
application.screenupdating=false
Don't forget to turn it back on at the end of the code!

Answer 3

My requirements ended up changing slightly. The QA lead wanted Metadata in the raw worksheet, so I had the full list of scenarios at my disposal instead of having to look at every row in the raw data. As a result, I could save and sort the scenario list to an array, and then do a .Find(parallelScenarioName(intPosition + 1)).row to get the row of the next scenario.
Because of this change, I did not fully implement and test Tim Williams solution which would iterate through every row in the data. I have to move on for now, but will revisit and test Tim's solution for my own knowledge soon.
The finished code is below.
'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