Extract subarray from jagged array and use as 1d array - arrays

I'm trying to reduce redundancy in my macros but I'm struggling with getting an element from a jagged array and using it elsewhere.
The premise is a single workbook with many sheets being split by groups of sheet names into new documents that I can then send to the process owners so they only get their own data.
Previously I was selecting sheet names listed explicitly and pasting to a new document that was named explicitly, but I had to run 10 separate almost identical macros to do that and I have heard of select being a bad choice in many instances as well.
Below is my latest attempt, the first issue is at the printOut line I get a Type Mismatch.
Sub CopyOut()
Dim printOut, groupNames, Group1, groupArray() As Variant
Dim n, j As Long
Dim reNamed, fileName As String
Dim ws As Worksheet
Dim wb1, wb2 As Workbook
groupNames = Array("Group 1", "Group 2", "Group 3", "Group 4") 'other arrays left off for length
Group1 = Array("FA_1A Report", "FA_1A", "FA_2ACS Report", "FA_2ACS", "FA_2BCS Report", "FA_2BCS", "FANUCMED Report", "FANUCMED", "FA_RRTP1 Report", "FA_RRPT1")
groupArray = Array(groupNames, Group1)
For n = 1 To UBound(groupArray)
fileName = "CS Data Sheet" & " " & Format(Date, "mmmyy") & "-" & groupArray(n - n)(n - 1) & ".xlsm" 'concat file name string. this is not just tacked on the end of reName because i use it on it's own later
reNamed = "C:\Users\xx\Desktop\" & fileName 'concat save location string
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Add 'create a new workbook, wb2
wb2.SaveAs fileName:=reNamed, FileFormat:=xlOpenXMLWorkbookMacroEnabled 'save with that name and location
printOut = Join(Application.Index(groupArray, n, 0), ",")
wb1.Sheets(printOut).Copy Before:=Workbooks(fileName).Sheets(1) 'copy the sheets for the group and paste into the newly created document
Next
End Sub
If I nix printOut altogether and put in a specific worksheet name instead it does work for just that one sheet (of course) but I need it to copy multiple to each new document.
I have also tried:
For n = 1 To UBound(groupArray)
...
for j= LBound(groupArray(n)) To UBound(groupArray(n))
wb1.Sheets(groupArray(n)(j)).Copy Before:=Workbooks(fileName).Sheets(1)
next
next
to iterate through the subarray and copy a sheet at a time, but it gives subscript out of range. With this version I tried various methods of making the groupArray(n)(j) value into a string or into a "worksheet" type to set as a variable and use the variable in the sheets().copy, to no avail.
Any idea where I could be going wrong?
thanks so much
EDIT:
I got my above code working by wrapping it in split (was trying to use printOut as an array when it was only a string) and fixing the arguments of Index as below, however the resulting code still needs work, since if a sheet is missing it won't run.
printOut = Split(Join(Application.Index(groupArray(n), 1, 0), ","), ",")

In my experience, if you find yourself hard-coding values like sheet names, group names, and other data directly in your code it tends to become difficult to maintain. Adding more groups, or re-shuffling the sheets in each group becomes problematic. My recommendation is to create a (possibly hidden) worksheet that maps your worksheet names into groups. Then you have a small set of code that operates directly on that.
My example data is set up like this:
Next, in its own code module, I created a few methods to work directly with this group map data. The main idea here is to move the group map data into a memory-based array. While in general I rarely use module-level global variables, I have one in this example to illustrate how to work with the data by only reading it into the array once every time the macro is executed.
(These are Subs and Functions. For my own code, I likely would have created a VBA class to handle the data in an object-oriented way.)
So there is a Private Sub to get the data:
Option Explicit
Private groupData As Variant
Private Sub GetGroupData()
Const GROUP_WS_NAME As String = "GroupMap"
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(GROUP_WS_NAME)
Dim lastRow As Long
Dim lastCol As Long
With ws
'--- how many columns of groups?
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastRow = .UsedRange.Find("*", , , , xlByRows, xlPrevious).Row
groupData = .Range("A1").Resize(lastRow, lastCol).Value
End With
End Sub
Now it's easy to figure out how many groups there are:
Public Function NumberOfGroups() As Long
If IsEmpty(groupData) Then GetGroupData
NumberOfGroups = UBound(groupData, 2)
End Function
And how many items in a particular group:
Public Function NumberInGroup(ByVal groupNumber As Long)
If IsEmpty(groupData) Then GetGroupData
'--- count the number of array values that have data
Dim i As Long
For i = LBound(groupData, 1) To UBound(groupData, 1)
If groupData(i, groupNumber) = vbNullString Then
'--- we found the first empty cell in this array, we're done
Exit For
Else
NumberInGroup = NumberInGroup + 1
End If
Next i
'--- subtract one to discount the header value
NumberInGroup = NumberInGroup - 1
End Function
The easiest of all is getting the value of any group:
Public Function GetGroupValue(ByVal groupNumber As Long, _
ByVal groupIndex As Long) As Variant
If IsEmpty(groupData) Then GetGroupData
'--- always add one to the index to account for the header value
GetGroupValue = groupData(groupIndex + 1, groupNumber)
End Function
Notice the check for If IsEmpty(groupData) Then GetGroupData at the beginning of each method. This makes sure the groupData array is always loaded if necessary.
This example gives it a quick test (in a different code module):
Option Explicit
Sub test()
Dim totalGroups As Long
totalGroups = NumberOfGroups()
Dim i As Long
Dim j As Long
For i = 1 To totalGroups
Dim totalInGroup As Long
totalInGroup = NumberInGroup(i)
For j = 1 To totalInGroup
Debug.Print "group " & i & " = " & GetGroupValue(i, j)
Next j
Next i
End Sub
Here's the whole group data code module in a single block:
Option Explicit
Private groupData As Variant
Private Sub GetGroupData()
Const GROUP_WS_NAME As String = "GroupMap"
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(GROUP_WS_NAME)
Dim lastRow As Long
Dim lastCol As Long
With ws
'--- how many columns of groups?
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastRow = .UsedRange.Find("*", , , , xlByRows, xlPrevious).Row
groupData = .Range("A1").Resize(lastRow, lastCol).Value
End With
End Sub
Public Function NumberOfGroups() As Long
If IsEmpty(groupData) Then GetGroupData
NumberOfGroups = UBound(groupData, 2)
End Function
Public Function NumberInGroup(ByVal groupNumber As Long)
If IsEmpty(groupData) Then GetGroupData
'--- count the number of array values that have data
Dim i As Long
For i = LBound(groupData, 1) To UBound(groupData, 1)
If groupData(i, groupNumber) = vbNullString Then
'--- we found the first empty cell in this array, we're done
Exit For
Else
NumberInGroup = NumberInGroup + 1
End If
Next i
'--- subtract one to discount the header value
NumberInGroup = NumberInGroup - 1
End Function
Public Function GetGroupValue(ByVal groupNumber As Long, ByVal groupIndex As Long) As Variant
If IsEmpty(groupData) Then GetGroupData
'--- always add one to the index to account for the header value
GetGroupValue = groupData(groupIndex + 1, groupNumber)
End Function

If I got this right, you have one master workbook with n sheets and you want to group some of them, then create a new workbook for each group and paste in its assigned sheets.
I think an approach where you keep a "config" file in your master workbook for setting up groups and sheets, is more suitable rather than editing into code. Example:
The below code will create a file using the names from column A and copy all the sheets defined on their respective row.
Option Explicit
Sub CopyOut()
Dim groupArr() As Variant
Dim wb2 As Workbook
Dim lastRow As Long, lastCol As Long, highestNumOfSheets As Long, i As Long, j As Long, arrColumns As Long
Dim reNamed As String, fileName As String, configSheet As String
Dim removedSheet1 As Boolean
' Modify the sheet name here
configSheet = "config"
' Build an array from sheet defined groups
With ThisWorkbook.Worksheets(configSheet)
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastRow
lastCol = .Cells(i, .Columns.Count).End(xlToLeft).Column
If lastCol > highestNumOfSheets Then highestNumOfSheets = lastCol
Next i
groupArr = .Range(.Cells(2, 1), .Cells(lastRow, highestNumOfSheets)).Value2
End With
Application.ScreenUpdating = False
For i = LBound(groupArr) To UBound(groupArr)
fileName = "CS Data Sheet " & Format(Date, "mmmyy") & "-" & groupArr(i, 1) & ".xlsm"
reNamed = Environ("UserProfile") & "\Desktop\" & fileName
removedSheet1 = False ' Reset this on each new workbook created
Set wb2 = Workbooks.Add
' Pick all the sheet names for the current group
For j = 2 To UBound(groupArr, 2)
' Skip empty values from array (if it's the case) and skip missing sheets
If Trim(groupArr(i, j)) <> vbNullString And SheetExists(groupArr(i, j)) Then
ThisWorkbook.Worksheets(groupArr(i, j)).Copy Before:=wb2.Worksheets(1)
' Remove Sheet1 from the new Workbook
If removedSheet1 = False Then
With Application
.DisplayAlerts = False
wb2.Worksheets("Sheet1").Delete
removedSheet1 = True
.DisplayAlerts = True
End With
End If
End If
Next j
' Here you might need an error handler if you think you're going to run the macro multiple times in the same day
' If the file exists already this will throw an error
' A quick lazy way is to add time (including seconds) when you define the file name above
wb2.SaveAs fileName:=reNamed, FileFormat:=xlOpenXMLWorkbookMacroEnabled
wb2.Close
If Not wb2 Is Nothing Then Set wb2 = Nothing
Next i
Application.ScreenUpdating = True
End Sub
Function SheetExists(ByVal sheetName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(sheetName)
On Error GoTo 0
If Not ws Is Nothing Then
SheetExists = True
Set ws = Nothing
End If
End Function
Of course it can be tweaked around, with error handling and other checks (depending on what you want to achieve entirely) but it should give you an alternative view of your code.
EDIT: Added a function to check if sheet exists.

Related

Looping VBA ranges and offsetting to specific table column and other values

the VBA code below scans two different datasets/tables in excel against possible matches in Worksheet 2 (aka SecondaryTable) and Worksheet 1 (aka MainTable). Both “Main” and “Secondary” Tables are Table Objects in Excel:
Sub looping()
Dim lRow As Long
Dim lCol As Long
Dim lRow2 As Long
Dim lCol2 As Long
Dim wordsArray() As Variant
wordsArray = Worksheets("SecondaryTable").Range("A2:A" & lRow2).Value
Dim word As Variant
Dim cell As Range
Set sht = Worksheets("MainTable")
Set sht2 = Worksheets("SecondaryTable")
lRow = sht.Range("A1").CurrentRegion.Rows.Count
lCol = sht.Range("A1").CurrentRegion.Columns.Count
lRow2 = sht2.Range("A1").CurrentRegion.Rows.Count
lCol2 = sht2.Range("A1").CurrentRegion.Columns.Count
For Each cell In Worksheets("MainTable").Range("I2:I" & lRow)
For Each word In wordsArray
If InStr(cell.Value, word) > 0 Then
cell.Offset(0, -2).Value = cell.Offset(0, -2).Value & " " & word
End If
Next word
Next cell
End Sub
I wanted to ask if there is any good way (after several failed attempts and errors via VBA in the last couple of days) of doing the following:
Is there any way of offsetting the value identified into a specific Table column instead of counting columns to determine exactly where the data will be populated / should be offset to? I tried replacing cell.Offset(0, -2).Value with a Table reference to the column name such as “Results” however I kept getting errors.
Would there any specific way after the code finds a match from wordsArray = Worksheets("SecondaryTable").Range("A2:A" & lRow2).Value to return a different value from an adjacent cell located in Range("B2:B" & lrow2).Value? The secondary table contains partial keywords in one column via which the loop is executed and a second adjacent column that contains the full name. I tried offsetting the variable word e.g., word.offset(0,1).Value in an effort to pull the name from Column 2 but only got errors.
Secondary Table example
Column A (keywords) Column B(full string)
Dog big dog
Cat small cat
Since you say Tables are Table Objects in Excel: utilise that fact. These are called ListObject's in VBA.
Replace the various NameOf... strings with your actual names
Sub looping()
Dim wordsArray() As Variant
Dim FullWordsArray() As Variant
Dim wb As Workbook
Dim sht As Worksheet
Dim sht2 As Worksheet
Dim loSecondary As ListObject
Dim loMain As ListObject
Set wb = ThisWorkbook ' or specify a workbook
Set sht = wb.Worksheets("MainTable")
Set sht2 = ws.Worksheets("SecondaryTable")
Set loMain = sht.ListObjects(1) ' or by name: Set loMain = sht.ListObjects("YourTableName')
Set loSecondary = sht2.ListObjects(1)
' get two arrays, one for lookup, and the other for replacements
wordsArray = loSecondary.ListColumns("NameOfWordColumn").DataBodyRange.Value2
FullWordsArray = loSecondary.ListColumns("NameOfFullWordColumn").DataBodyRange.Value2
Dim WordIdx As Long
Dim SearchCol As Long
Dim UpdateCol As Long
Dim rw As Long
Dim lr As ListRow
SearchCol = loMain.ListColumns("NameOfColumnToSearch").Index
UpdateCol = loMain.ListColumns("NameOfColumnToUpdate").Index
For Each lr In loMain.ListRows
With lr.Range
For WordIdx = 1 To UBound(wordsArray, 1)
If InStr(.Cells(1, SearchCol).Value2, wordsArray(WordIdx, 1)) > 0 Then
With .Cells(1, UpdateCol)
.Value2 = .Value2 & " " & FullWordsArray(WordIdx, 1)
End With
End If
Next
End With
Next
End Sub

Create a VBA Array from Column Headers?

I have a an export "NewExport" that always randomizes the columns of data I receive. I need these columns to align with the order of columns in "TheOrder", so this code will help to re-organize the export to align with the column headers I've already built.
I have 132 columns that need re-alignment, and while I can type it all out, there must be an easier way to align with the column headers I've already created. It should be noted that the below code is shamelessly copy/pasted from another StackOverflow answer.
Sub OrderColumns(ByVal NewExport As Workbook, ByVal TheOrder As Worksheet)
Dim correctOrder() As Variant
Dim lastCol As Long
Dim headerRng As Range, cel As Range
Dim mainWS As Worksheet
Set mainWS = NewExport.Worksheets("Sheet1")
'Need to figure out how to make this an array based on a Range
correctOrder() = Array(TheOrder.Range("A1:A132").Value)
With mainWS
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set headerRng = .Range(.Cells(1, 1), .Cells(1, lastCol))
End With
Dim newWS As Worksheet
Set newWS = Ninja.Sheets.Add
newWS.Name = "Rearranged Sheet"
Dim col As Long
With newWS
For col = 1 To lastCol
For Each cel In headerRng
If cel.Value = correctOrder(col - 1) Then
mainWS.Columns(cel.Column).Copy .Columns(col)
Exit For
End If
Next cel
Next col
End With
End Sub
While it's not as automated as I would have liked (and requires one piece of hard-coding), I was able to find a solution as such:
Dim correctOrder(132) As Variant
'132 will need to be changed if there's ever any more/less columns added/excluded
For i = 1 To 132
correctOrder(i - 1) = TheOrder.Range("A" & i).Value
Next
This solution gave me the array I was looking for for use later on.
I recently wrote a 'column finder' function for a project of mine.
I've modified it to suit your requirements below.
The function requires you pass the workbook your correct ordered headings are in to capture. You could modify this to require your TargetWorksheet instead so it's a bit more dynamic.
The function returns a single dimension Array.
The function finds the last used Column in the Target Worksheet allowing for changes in the number of column headings (as mentioned in your own answer which has the column number hard coded).
Public Function CorrectOrderHeadingsArrayFunction(ByRef TargetWorkbook As Workbook) As Variant()
With TargetWorkbook.Sheets(1) 'Change this to target your correct sheet
Dim LastColumn As Long
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
CorrectOrderHeadingsArrayFunction= Application.Transpose(Application.Transpose(.Range(.Cells(1, 1), .Cells(1, LastColumn)).Value)) 'This returns the array as single dimension rather than 2D
End With
End Function
As an example, below is some sample 'Test' code to show the concept of using this function .
You could call it like so, and loop through each element perhaps comparing another arrays elements to the correct order elements and do something when the correct order value is found.
Sub TestSub()
Dim CorrectOrderArray As Variant
Dim TargetCorrectOrderElement As Variant
Dim RandomOrderArray As Variant
Dim TargetRandomOrderElement As Variant
CorrectOrderArray = CorrectOrderHeadingsArrayFunction(Workbooks("Export (4).csv")) 'Change this to target your correct workbook
RandomOrderArray = Sheet1.Range("A1:AZ1000") 'Change this to target the correct range for your data.
For Each TargetCorrectOrderElement In CorrectOrderArray
For TargetRandomOrderElement = LBound(RandomOrderArray) To UBound(RandomOrderArray)
If RandomOrderArray(TargetRandomOrderElement) = TargetCorrectorderValue Then
'Do some code to write that column to your worksheet
Exit For 'Leaves the current iteration of the random order array loop to go to the next iteration of the correct order array
End If
Next TargetRandomOrderElement
Next TargetCorrectOrderElement
End Sub

Delete all contents except for first row for specific sheets in Excel

Please assist. I have this code here and it works for first sheet however, does not execute in the 2nd sheet. I think i'm missing a sheet syntax. thanks.
Dim arrSheets As Variant, sht As Variant
arrSheets = Array("tl_1", "tl_2")
For Each sht In arrSheets
Sheets(sht).UsedRange.Offset(1).ClearContents
Next sht
My 2 cents: do not rely on worksheet names. Instead, work with their (Name) property as seen from the Visual Basic Editor. Note that you can give significant names yourself instead of the default Sheet1..N ones. This way, your code will survive modifications to the names as seen from Excel, in the tabs at the bottom.
Option Explicit
Public Sub DoTheClearThing()
Dim loopVariant As Variant
Dim loopWorksheet As Excel.Worksheet
Dim worksheetsToConsider As Variant
'Use the (Name) property, as seen from the Visual Basic Editor, of the worksheets you're interested in.
'The array below is not a string array; it is an array of worksheet objects.
worksheetsToConsider = Array(TL_1, TL_2)
'The For's variable must be a Variant; you can then Set it to a variable of the Worksheet type and enjoy Intellisense.
For Each loopVariant In worksheetsToConsider
Set loopWorksheet = loopVariant
loopWorksheet.UsedRange.Offset(1).ClearContents
Next
End Sub
Here's what the worksheets' (Name) properties look like in my test Excel workbook:
From within your workbook's code, you can directly interact with worksheet objects using their (Name) property. Avoid ThisWorkbook.Worksheets("tl_1").SomeMethod and directly go with TL_1.SomeMethod. By the way, a worksheet's (Name) property can be read by code using its CodeName property.
Option Explicit
'This will do something to your target sheets,
'just make sure your "something" is what you want
Dim N As Long
Dim wsName As String
'Optional if included
For N = 1 To ThisWorkbook.Sheets.Count
wsName = ThisWorkbook.Worksheets(N).Name
If wsName = "tl_1" or wsName = "tl_2" Then
ThisWorkbook.Worksheets(N).UsedRange.Offset(1).ClearContents
Else 'Do Nothing
End If
Next N
Note: This is very worksheet name dependent and users can change those if you are not the only user. You may want to CodeName your sheets (properties Explorer and change the Name) then pull the CodeName.
You can use an array to hold the sheets names but it seems like more trouble than its worth unless you are going to load the names into the array.
-WWC
Worksheet.UsedRange does not always return the correct address. Consider the results of the test below:
Test Used Range
Sub Test()
Application.ScreenUpdating = False
Dim cell As Range, target As Range
Debug.Print "Data Range", "|"; "UsedRange"
Debug.Print String(24, "_")
With Worksheets.Add
Set target = .Range("B2:D2")
target.Value = 1
Debug.Print target.Address, "|"; .UsedRange.Address
End With
With Worksheets.Add
.Range("A1:G10").Interior.Color = 65535
Set target = .Range("B2:D2")
target.Value = 1
Debug.Print target.Address, "|"; .UsedRange.Address
End With
End Sub
Clear Non-Headers
Sub ClearNonHeaderRows()
Dim arrSheets As Variant, sht As Variant
Dim cell As Range
arrSheets = Array("tl_1", "tl_2")
For Each sht In arrSheets
With Worksheets(sht).UsedRange
Set cell = .Find("*", .Cells(1, 1))
If Not cell Is Nothing Then
cell.Offset(1).Resize(.Cells.Rows.Count - cell.row + .Cells(1, 1).row).EntireRow.ClearContents
End If
End With
Next sht
End Sub

Nesting For Loops with Arrays to assign variable

I'm trying to condense some existing code hopefully into an array within another existing loop.
1) Create new sheets within a workbook based on an array (TerrArray).
2) Format all new sheets the same way.
3) Declare a separate lastrow variable for each newly created sheet.
Dim Counter As Long
Dim TerrArray
Dim LongArray
Dim NAlr As Long, AUlr As Long, BRlr As Long, CAenlr As Long, CAfrlr As Long, DElr As Long, ESlr As Long, FRlr As Long, ITlr As Long, MXlr As Long, USAlr As Long, UK As Long, r As Long
TerrArray = Array("NA", "AU", "BR", "CAen", "CAfr", "DE", "ES", "FR", "IT", "MX", "USA", "UK")
LongArray = Array(LR, NAlr, AUlr, BRlr, CAenlr, CAfrlr, DElr, ESlr, FRlr, ITlr, MXlr, USAlr, UKlr)
''' Create sheets
For m = 0 To UBound(TerrArray)
Sheets.Add(After:=ActiveSheet).Name = TerrArray(m)
Next m
''' Loops formatting of each sheet
Counter = Sheets.Count
For i = 2 To Counter
Sheets(1).Cells(1, 1).EntireRow.Copy
Sheets(i).Cells(1, 1).PasteSpecial
[other formatting code, etc]
Next i
''' Assigns lastrow variable to each sheet
NAlr = Sheets("NA").Cells(Rows.Count, "B").End(xlUp).Row
AUlr = Sheets("AU").Cells(Rows.Count, "B").End(xlUp).Row
BRlr = Sheets("BR").Cells(Rows.Count, "B").End(xlUp).Row
[etc]
I can't figure out where to place LongArray in one of the 2 other loops order to use something like
LongArray(n) = Sheets(i).Cells(Rows.Count, "B").End(xlUp).Row
After the above code executes, I have functioning code that follows that can pick up the row count variables.
EDIT: Not sure if I'm going in the right direction
For m = 0 To UBound(TerrArray)
Sheets.Add(After:=ActiveSheet).Name = TerrArray(m)
LongArray(m) = Sheets(TerrArray(m)).Cells(Rows.Count, "B").End(xlUp).Row
Next m
Use a dictionary (follow that link for a similar SO question/answer where I explain how to use the dictionary class):
Const TERR as String ="NA,AU,BR,CAen,CAfr,DE,ES,FR,IT,MX,USA,UK"
Sub foo()
Dim dict = CreateObject("Scripting.Dictionary")
Dim t as Variant
Dim newSheet As Worksheet
For Each t in Split(TERR, ",")
' Create each sheet
Set newSheet = Sheets.Add(After:=ActiveSheet)
newSheet.Name = t
' Formatting stuff:
Sheets(1).Rows(1).EntireRow.Copy
newSheet.Cells(1, 1).PasteSpecial
' [other formatting code, etc]
With newSheet
Sheets(1).Rows(1).EntireRow.Copy
' formatting code probably goes here
dict.Add(t, .Cells(.Rows.Count, 2).End(xlUp).Row)
End With
Next
' Now, you can reference the last row associated with each
' Instead of using variable NAlr, just refer to the dictionary value associated with the "NA" key:
MsgBox dict("NA")
'etc...
Or, just write a Function to get the last row, since the last row may change it's probably not a great idea to get in the habit of assigning these values directly / statically.

Not responding state during search in VBA

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
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
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!
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

Resources