Im trying to write my first more extended macro in VBA and I'm having trouble with testing if a value in Array 1 is also in Array 2. Below my code with comments. I hope someone can help me with this as it's driving me crazy :-) Thank you in advance!
Sub PullingTrxData()
Dim TrxArray As Variant
Dim InvArray As Variant
Dim emailColumn As Range
Dim wsTrx As Worksheet
Dim wsInvoices As Worksheet
Dim trxRange As Range
Dim LastRow As Long
Dim i As Long
Dim j As Long
'setting sheets as variables
Set wsTrx = ThisWorkbook.Worksheets("Transactions")
Set wsInvoices = ThisWorkbook.Worksheets("Invoices Summary")
'finding last non empty row number in column c - email Invoices worksheet
LastRow = wsInvoices.Cells(wsInvoices.Rows.Count, "C").End(xlUp).Row
wsInvoices.Activate
'setting range of all emails already in invoices
If wsInvoices.Range("C3") <> "" Then
Set emailColumn = wsInvoices.Range("C2", Range("C2").End(xlDown))
Else: Set emailColumn = wsInvoices.Range("C2")
End If
'loading emails already on invoices sheet into an array
InvArray = emailColumn.Value
'setting range of all transactions -why do I have to activate wsTrx for it to work?
wsTrx.Activate
Set trxRange = wsTrx.Range("A2", Range("A1").End(xlToRight).End(xlDown))
'loading transactions into array
TrxArray = trxRange.Value
'looping through array and checking if the email address from TransactionsList is already listed on Invoices Summary
For i = LBound(TrxArray, 1) To UBound(TrxArray, 1)
For j = LBound(InvArray) To UBound(InvArray)
'testing if email in TrxArray(i,1) already in InvArray(j) if yes then next else add to first empty cell in column C on Invoices summary sheet
If TrxArray(i, 1) = InvArray(j) Then
Next j
Else: ThisWorkbook.Worksheets("Invoices Summary").Range("C" & LastRow).Offset(1, 0).Value = InvArray(j)
End If
Next j
Next i
End Sub
Match Value of One Array in Another
Instead of two loops, you could use Application.Match with one loop:
Dim Trx1Array As Variant: Trx1Array = trxRange.Columns(1).Value
For i = 1 To UBound(InvArray, 1)
If IsError(Application.Match(InvArray(i, 1), Trx1Array, 0)) Then ' not found
ThisWorkbook.Worksheets("Invoices Summary").Range("C" & LastRow) _
.Offset(1, 0).Value = InvArray(i)
'Else ' found (in Trx1Array)
End If
Next i
Related
When I run this code, it is getting a subscript out of range error in this specific line:
If i = ws_External_Test_Matrix.Cells(ws_External_Test_Matrix.Rows.Count, 1).End(xlUp).Row Then
arr_Test_Case_Rows(2, UBound(arr_Test_Case_Rows, 2)) = i ' <-- This line
End If
I unfortunately did not write this code, but my understanding is that i is supposed to be the upper bound of the array above. I've tried troubleshooting a bit and it appears that arr_Test_Case_Rows(2, UBound(arr_Test_Case_Rows, 2)) = 0 which would suggest that the Array is unallocated and therefore the error is coming from somewhere above this line. From what I have read it could be from the redim portions but I've tried ReDim arr_Test_Case_Rows(1 To 2, 1 To 1) right before the error line and while it ran, the results did not populate as expected. Anything I can do here to fix this?
Sub Populate_Test_Matrix()
Dim str_External_Test_Matrix_Name As String
Dim ws_External_Test_Matrix As Worksheet
Dim ws_TestMatrix_Tab As Worksheet
Dim ws_ItemInputs As Worksheet
Dim ws_ItemOutputs As Worksheet
Dim rng_Header_Copy_Start As Range
Dim rng_Header_Copy_End As Range
Dim rng_Copy_Start As Range
Dim rng_Copy_End As Range
Dim rng_Paste_Start As Range
Dim i As Long
Dim j As Long
Dim arr_Test_Case_Rows() As Variant
Dim boo_Empty_Row_Ind As Boolean
Dim xlx As XlXmlExportResult
Dim xmlmp As XmlMap
Dim str_Replace_String As String
Dim arr_XML_String_Holder() As Variant
Dim str_XML_Save_Name As String
Dim str_Record As String
Dim str_State As String
Dim int_Test_Case_Start_Row As Long
Application.ScreenUpdating = False
str_External_Test_Matrix_Name = Open_Workbook(ThisWorkbook.Sheets("Macro_Menu").Range("Test_Case_Matrix_Path").Value)
Set ws_External_Test_Matrix = Workbooks(str_External_Test_Matrix_Name).Sheets("MATRIX")
Set ws_TestMatrix_Tab = ThisWorkbook.Sheets("TESTMatrix")
Set ws_ItemInputs = ThisWorkbook.Sheets("ITEMINPUTS")
Set ws_ItemOutputs = ThisWorkbook.Sheets("ITEMOUTPUTS")
'Get start and end row numbers of test cases from External Test Matrix, and record into array
boo_Empty_Row_Ind = False
'Determine first row (header row) of Test Cases, to determine which row to begin looping from when
'finding Test Cases
int_Test_Case_Start_Row = ws_External_Test_Matrix.Range("A:A").Find(what:="Record", LookIn:=xlValues, LookAt:=xlWhole, After:=ws_External_Test_Matrix.Cells(ws_External_Test_Matrix.Rows.Count, 1)).Row
For i = int_Test_Case_Start_Row To ws_External_Test_Matrix.Cells(ws_External_Test_Matrix.Rows.Count, 1).End(xlUp).Row
'If 0, then row is empty
If (Application.CountA(ws_External_Test_Matrix.Cells(i, 1).EntireRow) = 0) And _
(ws_External_Test_Matrix.Cells(i, 1).EntireRow.Interior.ColorIndex = 1) Then 'If 1, then row is colored black
If boo_Empty_Row_Ind = False And (Not Not arr_Test_Case_Rows) <> 0 Then 'Array is allocated
arr_Test_Case_Rows(2, UBound(arr_Test_Case_Rows, 2)) = i - 1
End If
boo_Empty_Row_Ind = True
Else 'Row is NOT empty
'If we previously hit empty row and current row is now non-empty, we have test case to record
If boo_Empty_Row_Ind = True Then
boo_Empty_Row_Ind = False
If (Not Not arr_Test_Case_Rows) = 0 Then 'if 0, then array is unallocated
ReDim arr_Test_Case_Rows(1 To 2, 1 To 1)
Else
ReDim Preserve arr_Test_Case_Rows(1 To 2, 1 To UBound(arr_Test_Case_Rows, 2) + 1)
End If
'arr_Test_Case_Rows(1, X) = start row of test case
'arr_Test_Case_Rows(2, X) = end row of test case
arr_Test_Case_Rows(1, UBound(arr_Test_Case_Rows, 2)) = i
End If
End If
'If I = last row of loop counter
If i = ws_External_Test_Matrix.Cells(ws_External_Test_Matrix.Rows.Count, 1).End(xlUp).Row Then
arr_Test_Case_Rows(2, UBound(arr_Test_Case_Rows, 2)) = i ' <-- This line
End If
Next i
The business case context- the broader program that this module is in takes in a sheet of data and reformats it to be uploaded in another program.
The sheet is made up of one header row followed by rows of records of varying size (1 record could be 1 row, all the way up to 7). The blank rows are used to separate when one record ends and another begins.
This particular module is recording where records exist (not blank row) and the line where it breaks is referring to the final non blank row in the sheet.
In this screenshot it is 40 rows, but the actual case is 55.
Here's a slightly different approach using a Collection instead of an array:
Sub Populate_Test_Matrix()
Dim wb As Workbook, extWb As Workbook, wsExtTM As Worksheet, colRecs As Collection
Dim inRecord As Boolean, firstRecordRow, lastRow As Long
Dim rw As Range, rec, startRow As Long
'better for Open_Workbook to return a reference to the workbook, instead of its name...
Set extWb = Open_Workbook(wb.Sheets("Macro_Menu").Range("Test_Case_Matrix_Path").Value)
Set wsExtTM = extWb.Sheets("MATRIX")
firstRecordRow = Application.Match("Record", wsExtTM.Columns("A"), 0)
If IsError(firstRecordRow) Then
MsgBox "'Record' not found in ColA", vbCritical
Exit Sub
End If
Set colRecs = New Collection 'using a collection seems simpler
inRecord = False
Set rw = wsExtTM.Rows(firstRecordRow)
lastRow = wsExtTM.Cells(wsExtTM.Rows.Count, 1).End(xlUp).Row
Do While rw.Row <= lastRow
If Not RowIsEmpty(rw) Then
If Not inRecord Then
startRow = rw.Row 'save the start row
inRecord = True
End If
Else
If inRecord Then 'were we previously in a record?
colRecs.Add Array(startRow, rw.Row - 1)
inRecord = False
End If
End If
Set rw = rw.Offset(1, 0) 'next row
Loop
colRecs.Add Array(startRow, lastRow) 'close the last record
For Each rec In colRecs
Debug.Print "Start row:" & rec(0), "End row:" & rec(1)
Next rec
End Sub
'factored out a bit of logic...
Function RowIsEmpty(rw As Range) As Boolean
'using color not colorindex...
RowIsEmpty = Application.CountA(rw) = 0 And rw.Interior.Color = vbBlack
End Function
I have two data workbooks. One dataset is of refused orders and the other dataset is for current orders. I want to find if i can match orders so that i can utilize the orders that I have in refused file. This way i wont have to make the current order and can simultaneously reduce my stack of orders that have been refused by customers. Here is my Data sheets for refused and current/printed orders.
Current/Printed Orders
Here is datasheet for the refused orders.
Refused Orders
I need to match orders on three things. First the design name needs to match, the product name needs to match and the size needs to match in order to get an "order match".
How can I use excel vba to find matches and create a new excel worksheet in the current order workbook that can show the orders that match between both data sets. The final data output would be order number against order number from both the files.
I am just beginning to learn vba but this is a complex problem that i can not solve. Please help. I wrote a code but it does not run. It says object not defined. Code that i wrote is :
Sub Comparetwosheets()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ws1row As Long, ws2row As Long, w1scol As Integer, ws2col As Integer
Dim report As Worksheet
Dim row As Long, col As Integer
Dim R1 As Range
Set R1 = Union(col(5), col(7), col(10))
Set report = Worksheet.Add
'Set numrows = number of rows of data
NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
' Select cell a1.
Range("A1").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
x = 2
Do While x < NonBlank
x = x + 1
Do While (ws1.R1 = ws2.R1)
If ws1.rw2 = ws2.rw2 Then
report.Cells(1, 1).Value = "Match"
Else: x = x + 1
Loop
Loop
'Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
End Sub
This should be able to do it for you. You are able to set the following variables in the CompareWorksheet subroutine to what you need then to be (dataSet1, dataSet2, colPos1, colPos2, rowStart1, rowStart2). I am using a random dataset from the world bank.
Sub CompareWorksheet()
Dim dataSet1, dataSet2 As Variant
Dim workbook1, workbook2 As String
Dim worksheet1, worksheet2 As String
Dim rowStart1, rowStart2 As Integer
'Get the data into the dataSet variable using a function that goes through each workbook/sheet
workbook1 = "dashboard-data-latest1.xlsx"
worksheet1 = "2. Harmonized Indicators"
dataSet1 = SheetToDataSet(workbook1, worksheet1)
'Get the data into the dataSet variable using a function that goes through each workbook/sheet
workbook2 = "dashboard-data-latest.xlsx"
worksheet2 = "2. Harmonized Indicators"
dataSet2 = SheetToDataSet(workbook2, worksheet2)
'Set this do what columns you are interested in comparing
colPos1 = Array(1, 2, 3)
colPos2 = Array(1, 2, 3)
'Set for where you want to start 1 would be row 1/now Header.
rowStart1 = 2
rowStart2 = 2
'Compares the dataSets
Compare2Sheets dataSet1, dataSet2, colPos1, colPos2, rowStart1, rowStart2
End Sub
Function Compare2Sheets(dataSet1 As Variant, dataSet2 As Variant, colPos1 As Variant, colPos2 As Variant, rowStart1 As Variant, rowStart2 As Variant)
If UBound(colPos1) = UBound(colPos2) Then
For I = rowStart1 To UBound(dataSet1, 1)
For j = rowStart2 To UBound(dataSet2, 1)
matchFlag = 0
For k = 0 To UBound(colPos1)
If dataSet1(I, colPos1(k)) = dataSet2(j, colPos2(k)) Then
matchFlag = matchFlag + 1
End If
Next k
If matchFlag = (UBound(colPos1) + 1) Then
Debug.Print ("Match found in Workbook 1 at row " & I & " and Workbook 2 at row " & j)
End If
Next j
Next I
End If
End Function
Function SheetToDataSet(workbookName As Variant, worksheetName As Variant) As Variant
'SET PAGE CHARACTERISTICS
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'DECLARE VARIABLE
Dim x_matrix As Range
Dim x_copyrange As String
Dim length, lastColumn As Integer
'DEFINE VARIABLE
Workbooks(workbookName).Worksheets(worksheetName).Activate
length = 0
lastColumn = 0
For I = 1 To 10
If length < Workbooks(workbookName).Worksheets(worksheetName).Cells(Rows.Count, I).End(xlUp).Row Then
length = Workbooks(workbookName).Worksheets(worksheetName).Cells(Rows.Count, I).End(xlUp).Row
End If
If lastColumn < Workbooks(workbookName).Worksheets(worksheetName).Cells(I, Columns.Count).End(xlToLeft).Column Then
lastColumn = Workbooks(workbookName).Worksheets(worksheetName).Cells(I, Columns.Count).End(xlToLeft).Column + 10
End If
Next I
'Let x_copyrange = .Range(.Cells(1, 1), .Cells(length, lastColumn))
'Return
SheetToDataSet = Workbooks(workbookName).Worksheets(worksheetName).Range(Cells(1, 1), Cells(length, lastColumn))
End Function
I have a vba macros that checks to see if there are duplicates in Column A & checks to see if there is a certain value in Column B but was wondering if there was a way to convert it to using with an array. The current code works great but I ran into a file that has over 153,000 rows in it & it takes the macros hours to run.
I can get it to find duplicates in Column A with an Array but can not figure out how to also check to see if it matches a certain value in Column B.
This is what I want it to do:
If match:
If not a match:
Here is the code I have right now to find duplicates not using an array:
Dim cell As Range
Dim wbook As Workbook
Dim wsheet As Worksheet
Dim sname As Range
Dim cname As Range
Dim rngA As Range
Dim dupA As Range
Dim dupB As Range
Dim strName As String
Set wbook = ActiveWorkbook 'Current Workbook
Set wsheet = Sheets("OFA_CP_OUT_202112_Without_Match") 'Worksheet Name
Set sname = Range("A2:H2426") 'Range for sorting and aligning columns A:H
Set cname = Sheets("OFA_CP_OUT_202112_Without_Match").Range("F2:F2426") 'Sheet Name & Range to format currency
Set rngA = Range("A2:A2426") 'Range to change column A to uppercase & find if a cell contains an A, B or S
Set dupA = wsheet.Range("A2:A2426") 'Range to find duplicates in column A
Set dupB = wsheet.Range("B2:B2426") 'Range to find year & month in column B (ex: 202112)
strName = "202112" 'year & month to search for in column B
'Looks for duplicates and highlights them yellow in column A & column B
For Each cell In dupA
If WorksheetFunction.CountIfs(dupA, "=" & cell.Value, dupB, "=" & cell.Offset(0, 1).Value) > 1 Then
cell.Interior.ColorIndex = 6
cell.Offset(0, 1).Interior.ColorIndex = 6
End If
Next cell
Here is the code that I got working using an array to find duplicates:
Sub Dupes()
Dim Ws As Worksheet
Dim LastRow As Long, i As Long, j As Long, DupCounter As Long, DupPos As Long
Dim MatNo As String
Dim Found As Boolean
Dim ArrDuplicates() As Variant 'Declare dynamic array
Set Ws = ThisWorkbook.Sheets(1)
'Redimennsion/change size of declared array
ReDim ArrDuplicates(1 To 2, 1 To 1)
DupCounter = 1
With Ws
'find last row with data in column "A"
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'Loop all rows from 1 to last
For i = 1 To LastRow
'reset variables for each loop
Found = False
DupPos = 0
MatNo = .Cells(i, 1)
'Search array with previous data and look for duplicates
For j = LBound(ArrDuplicates(), 2) To UBound(ArrDuplicates(), 2)
'If material number currently checked found in array
If MatNo = ArrDuplicates(1, j) Then
'remember position of source data in array (first occurence
'of material number)
DupPos = j
'set "Found" marker
Found = True
'leave loop
Exit For
End If
Next j
'if no duplicate found
If Not Found Then
'redimension array. "Preserve" keyword added to keep values
'already existing in array
ReDim Preserve ArrDuplicates(1 To 2, 1 To DupCounter)
'insert new data to array ((first occurance of material number)
ArrDuplicates(1, DupCounter) = MatNo
DupCounter = DupCounter + 1 'increase counter used to redimension array
Else 'if material number found in array
'change font color
.Cells(i, 1).Font.Color = vbRed
End If
Next i
End With
End Sub
Thanks for your help!
This should be faster:
Sub FlagDups()
Dim wb As Workbook, wsheet As Worksheet
Dim dupA As Range, arrA, dupB As Range, arrB
Dim dict As Object, i As Long, k, rng As Range
Set dict = CreateObject("scripting.dictionary")
Set wb = ActiveWorkbook
Set wsheet = wb.Worksheets("OFA_CP_OUT_202112_Without_Match")
Set dict = CreateObject("scripting.dictionary")
Set dupA = wsheet.Range("A2:A2426") 'Range to find duplicates in column A
Set dupB = wsheet.Range("B2:B2426") 'Range to find year & month in column B (ex: 202112)
arrA = dupA.Value 'read all the data
arrB = dupB.Value
wsheet.Range("A1:B10000").Interior.ColorIndex = xlNone 'clear any existing fill
For i = LBound(arrA) To UBound(arrA) 'loop over the data arrays
k = arrA(i, 1) & Chr(0) & arrB(i, 1) 'composite key from A, B
If Not dict.exists(k) Then
dict.Add k, i 'novel pair of values: store row index
Else
If dict(k) > 0 Then 'need to process store row index?
addCell rng, dupA.Cells(dict(k)) 'collect the first instance of this pair
addCell rng, dupB.Cells(dict(k))
dict(k) = 0 'flag as collected
End If
addCell rng, dupA.Cells(i) 'collect current instance
addCell rng, dupB.Cells(i)
End If
Next i
If Not rng Is Nothing Then rng.Interior.Color = vbYellow 'any cells to color?
End Sub
'build a range by adding rngAdd to rngTot
Sub addCell(rngTot As Range, rngAdd As Range)
If rngTot Is Nothing Then
Set rngTot = rngAdd
Else
Set rngTot = Application.Union(rngTot, rngAdd)
End If
End Sub
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.
I have data in columns P,Q,R. I would like to filter through R, and make a new Worksheet for each unique item in Column R. This new worksheet will also bring along the associated values in P and Q.
Thus far I have learned how to filter the data in R and put the unique values into an array. For each value in the array I made a new sheet named Array1(i) because I am unable to convert the value into a string for some reason. How can I do this in an optimized fashion such that I create a new sheet for each unique value in R and bring along the values in the same rows in P and Q as well? Here is my code:
Also, how do I declare the array dynamically rather than hard coding 50? How can I use a dynamic range for column R?
Note the values in the array will be something like 6X985
Sub testarray()
Dim TestRg As Excel.Range
Dim Array1(50) As Variant
Dim SheetName As String
Dim i, j, k As Integer
i = 1
Set TestRg = Range("R1:R36879")
TestRg.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
For Each c In TestRg.SpecialCells(xlCellTypeVisible)
Array1(i) = c.Value
'SheetName = CStr(c.Value)
Worksheets.Add.Name = i
i = i + 1
Next c
j = i - 1
i = 1
Worksheets("Sheet1").ShowAllData
For Each c In Range("S3:S" & j)
c.Value = Array1(i)
i = i + 1
Next c
k = 1
For Each d In Range("T3:T" & j)
d.Value = k
k = k + 1
Next d
End Sub
The code itself is kind of advanced, I added comments to assist with understanding. I hope it helps:
Sub tgr()
Dim wsData As Worksheet
Dim wsNew As Worksheet
Dim rngData As Range
Dim xlCalc As XlCalculation
Dim arrUnq() As Variant
Dim strSheetName As String
Dim UnqIndex As Long
Dim i As Long
Set wsData = Sheets("Sheet1")
Set rngData = wsData.Range("R1", wsData.Cells(Rows.Count, "R").End(xlUp))
'Disable application items to let code run faster
With Application
xlCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
'Re-enable all the application items just in case there's an error
On Error GoTo CleanExit
'Get the list of unique values from rngData, sorted alphabetically
'Put that list into the arrUnq array
With Sheets.Add
rngData.AdvancedFilter xlFilterCopy, , .Range("A1"), True
.UsedRange.Sort .UsedRange, xlAscending, Header:=xlYes
arrUnq = Application.Transpose(.Range("A2", .Cells(Rows.Count, "A").End(xlUp)).Value)
.Delete
End With
For UnqIndex = LBound(arrUnq) To UBound(arrUnq)
'Verify a valid worksheet name
strSheetName = arrUnq(UnqIndex)
For i = 1 To 7
strSheetName = Replace(strSheetName, Mid(":\/?*[]", i, 1), " ")
Next i
strSheetName = Trim(Left(WorksheetFunction.Trim(strSheetName), 31))
'Check if worksheet name already exists
If Not Evaluate("ISREF('" & strSheetName & "'!A1)") Then
'Sheet doesn't already exist, create sheet
Sheets.Add(After:=Sheets(Sheets.Count)).Name = strSheetName
End If
Set wsNew = Sheets(strSheetName)
wsNew.UsedRange.Clear
'Filter for the unique data
With rngData
.AutoFilter 1, arrUnq(UnqIndex)
'Copy the data from columns P:R to the new sheet
Intersect(wsData.Range("P:R"), .EntireRow).SpecialCells(xlCellTypeVisible).Copy wsNew.Range("A1")
End With
Next UnqIndex
rngData.AutoFilter 'Remove any remaining filters
CleanExit:
With Application
.Calculation = xlCalc
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
If Err.Number <> 0 Then
MsgBox Err.Description, , "Error: " & Err.Number
Err.Clear
End If
End Sub