VBA Excel Counting Specific Values - arrays

I'm trying to write a program that will loop through cells of a specific column (assigned by the user), find new values in those cells and count how many times a specific value is found. The main problem I'm having right now is that this is hard-coded like below:
Function findValues() As Long
For iRow = 2 To g_totalRow
If (ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text = "") Then
nullInt = nullInt + 1
ElseIf (someValue1 = "" Or someValue1 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue1 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt1 = someInt1 + 1
ElseIf (someValue2 = "" Or someValue2 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue2 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt2 = someInt2 + 1
ElseIf (someValue3 = "" Or someValue3 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue3 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt3 = someInt3 + 1
ElseIf (someValue4 = "" Or someValue4 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue4 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt4 = someInt4 + 1
ElseIf (someValue5 = "" Or someValue5 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue5 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt5 = someInt5 + 1
ElseIf (someValue6 = "" Or someValue6 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue6 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt6 = someInt6 + 1
ElseIf (someValue7 = "" Or someValue7 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue7 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt7 = someInt7 + 1
ElseIf (someValue8 = "" Or someValue8 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue8 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt8 = someInt8 + 1
ElseIf (someValue9 = "" Or someValue9 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue9 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt9 = someInt9 + 1
ElseIf (someValue10 = "" Or someValue10 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue10 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt10 = someInt10 + 1
End If
Next iRow
End Function
Here, if the ActiveCell is blank then the nullInt will get incremented, if the ActiveCell has some value then it'll find which of the variables has that same value or the ActiveCell value will be assigned to one of the variables. I created ten variables strictly for testing purposes but I need to make up to one hundred. I was wondering if there was a way to complete this quickly. The only way I could think of was to create a String array and an Int array and store the values that way. However I'm not sure if this is the best way to get this done.
Edit
This portion is directed specifically to dictionaries. Say there is a specific column titled "State". This contains the 50 North American states. Some of these states are repeated and there is a total of 800 values in this column. How do I keep track of how many times (for example) Texas gets hit?
Thank you,
Jesse Smothermon

You should be able to do this with a Dictionary (see Does VBA have Dictionary Structure?)
This code hasn't been tested but should give you a start.
Function findValues() As Scripting.Dictionary
Dim cellValue
Dim dict As New Scripting.Dictionary
For iRow = 2 To g_totalRow
cellValue = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
If dict.Exists(cellValue) Then
dict.Item(cellValue) = dict.Item(cellValue) + 1
Else
dict.Item(cellValue) = 1
End If
Next iRow
Set findValues = dict
End Function
Sub displayValues(dict As Scripting.Dictionary)
Dim i
Dim value
Dim valueCount
For i = 1 To dict.count
valueCount = dict.Items(i)
value = dict.Keys(i)
ActiveWorkbook.Sheets(sheetName).Cells(i, 3).Text = value
ActiveWorkbook.Sheets(sheetName).Cells(i, 4).Text = valueCount
Next i
End Sub
Sub RunAndDisplay()
Dim dict
Set dict = findValues
displayValues dict
End Sub

I've drafted a code for you, hope it helps. I added comments to make each step clearer for you. I believe that simply setting the proper values in the 1st step might make it work for you.
Still, would worth to understand what the code does to help you in the future.
Hope it fits your needs!
Option Explicit
Sub compareValues()
Dim oSource As Excel.Range
Dim oColumn As Excel.Range
Dim oCell As Excel.Range
Dim sBookName As String
Dim sSheetCompare As String
Dim sSheetSource As String
Dim sUserCol As String
Dim sOutputCol As String
Dim sFirstCell As String
Dim vDicItem As Variant
Dim sKey As String
Dim iCount As Integer
Dim sOutput As String
Dim oDic As Scripting.Dictionary
'1st - Define your source for somevalues and for the data to be compared
sBookName = "Book1"
sSheetCompare = "Sheet1"
sSheetSource = "Sheet2"
sFirstCell = "A1"
sOutputCol = "C"
'2nd - Define the 'somevalues' origin value; other values will be taken
' from the rows below the original value (i.e., we'll take our
' somevalues starting from sSheetSource.sFirstCell and moving to the
' next row until the next row is empty
Set oSource = Workbooks(sBookName).Sheets(sSheetSource).Range(sFirstCell)
'3rd - Populate our dictionary with the values beggining in the sFirstCell
populateDic oSource, oDic
'At this stage, we have all somevalues in our dictionary; to check if the
' valuesare as expected, uncomment the code below, that will print into
' immediate window (ctrl+G) the values in the dictionary
For Each vDicItem In oDic
Debug.Print vDicItem
Next vDicItem
'4th - ask the user for the column he wants to use; Use single letters.
' E.g.: A
sUserCol = InputBox("Enter the column the data will be compared")
'5th - scan the column given by the user for the values in the dictionary
Set oColumn = Workbooks(sBookName).Sheets(sSheetCompare).Columns(sUserCol)
'6th - Now, we scan every cell in the column
For Each oCell In oColumn.Cells
sKey = oCell.Value
'7th - Test the special case when the cell is empty
If sKey = "" Then oDic("Empty") = oDic("Empty") + 1
'8th - Test if the key value exists in the dictionary; if so, add it
If oDic.Exists(sKey) Then oDic(sKey) = oDic(sKey) + 1
'9th - Added to exit the for when row reaches 1000.
If oCell.Row = 1000 Then Exit For
Next oCell
'10th - Now, we print back the counters we found, only for sample purposes
' From now on, is up to you how to use the dictionary :)
iCount = 1
Set oColumn = Workbooks(sBookName).Sheets(sSheetCompare).Columns(sOutputCol)
Set oCell = oColumn.Cells(1, 1)
For Each vDicItem In oDic
If oDic(vDicItem) > 0 Then
oCell.Value = vDicItem
oCell.Offset(0, 1).Value = oDic(vDicItem)
Set oCell = oCell.Offset(1, 0)
End If
Next vDicItem
End Sub
Sub populateDic(ByRef oSource As Excel.Range, _
ByRef oDic As Scripting.Dictionary)
'Ideally we'd test if it's created. Let's just set it for code simplicity
Set oDic = New Scripting.Dictionary
'Let's add an 'empty' counter for the empty cells
oDic.Add "Empty", 0
While Len(oSource.Value) > 0
'If the data is not added into somevalues dictionary of values, we add
If Not oDic.Exists(oSource.Value) Then oDic.Add CStr(oSource.Value), 0
'Move our cell to the next row
Set oSource = oSource.Offset(1, 0)
Wend
End Sub

Related

Loop Through Org Employee ID Arrays using Begin With Filter

I have a report with a summary page that has all of the employee ID's listed and each employee belongs to a specific group. I'm trying to have my macro filter through the arrays for each group with each array containing the EID numbers and then export the filtered data into a separate sheet.
The issue I'm running into is, I have one group that contains about 20 EIDs and I'm using the "begin with filtering method" such as "1156*" which only seems to work with up to two values in the array only. I'm using this method because the EID's in the summary page are shown for example "11569-Org1". Any help to work around this would be appreciated.
Dim EIDNumbers(1 to 3) As Variant
EIDNumbers(1) = Array("16799*", "17900*")
EIDNumbers(2) = "22222*"
EIDNumbers(3) = Array("88888*","90000*","88444*")
For n = UBound(GroupNames) To LBound(GroupNames) Step -1
If IsArray(EIDNumbers(n)) Then
dataRG.AutoFilter 11, EIDNumbers(n), xlFilterValues
Else
dataRG.AutoFilter 11, EIDNumbers(n)
End If
Set fdataRG = mainWS.Range("A1").EntireColumn
fdataCT = Application.WorksheetFunction.Subtotal(103, fdataRG) - 1
If fdataCT > 1 Then ' add additional subws
Set subWS = wb.Worksheets.Add(After:=mainWS)
subWS.Name = OrgNames(n)
Set dfcell = subWS.Range("A1")
dataRG.SpecialCells(xlCellTypeVisible).Copy dfcell
End If
Next n
Filter Data When More Than Two WildCard Criteria
Dim LeftEIDs(1 To 3) As Variant
LeftEIDs(1) = Array("16799*", "17900*")
LeftEIDs(2) = Array("22222*")
LeftEIDs(3) = Array("88888*", "90000*", "88444*")
' Write the data (the EIDs) from the EID column to the keys of a dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim Data: Data = dataRG.Columns(11).Value
Dim rCount As Long: rCount = UBound(EIDs, 1)
Dim r As Long, cString As String
For r = 2 To rCount
cString = CStr(Data(r, 1))
If Len(cString) > 0 Then dict(cString) = Empty
Next r
' Write the matches per group to the keys of another dictionary
' and use them to filter by the EID column and to copy
' the data to a new worksheet.
Dim cDict As Object: Set cDict = CreateObject("Scripting.Dictionary")
cDict.CompareMode = vbTextCompare
Dim LeftEID, eKey, e As Long, n As Long
If mainWS.FilterMode Then mainWS.ShowAllData ' not sure about 'mainWS'!?
For n = UBound(LeftEIDs) To LBound(LeftEIDs) Step -1
For Each eKey In dict.Keys
For Each LeftEID In LeftEIDs(n)
If eKey Like LeftEID Then
cDict(eKey) = Empty
dict.Remove eKey
Exit For
End If
Next LeftEID
Next eKey
If cDict.Count > 0 Then
dataRG.AutoFilter 11, cDict.Keys, xlFilterValues
Set subWS = wb.Worksheets.Add(After:=mainWS)
subWS.Name = OrgNames(n)
Set dfcell = subWS.Range("A1")
dataRG.SpecialCells(xlCellTypeVisible).Copy dfcell
mainWS.ShowAllData ' not sure about 'mainWS'!?
cDict.RemoveAll
End If
Next n
'mainWS.autfiltermode = False ' not sure about 'mainWS'!?

SUMIFS faster in vba array and scripting.dictionary

I want to use the vba sumifs array and scripting.dictionary because there are a hundred thousand records there may be the best solution. For information sheet "DBALL" is the source and sheet "RECON" is the result. I also found the vba code below but it doesn't match the result.
info formula sheet "RECON" column B "In" = SUMIFS(DBALL!$A$2:$A$5,DBALL!$C$2:$C$5,RECON!$A2,DBALL!$B$2:$B$5,RECON!B$1)
info formula sheet "RECON" column c "Out" = SUMIFS(DBALL!$A$2:$A$5,DBALL!$C$2:$C$5,RECON!$A2,DBALL!$B$2:$B$5,RECON!C$1)
info formula sheet "RECON" column d "difference" = B2-C2
Thanks
Sub SUMIFSFASTER()
Dim arr, ws, rng As Range, keyCols, valueCol As Long, destCol As Long, i As Long, frm As String, sep As String
Dim t, dict, arrOut(), arrValues(), v, tmp, n As Long
keyCols = Array(2, 3) 'these columns form the composite key
valueCol = 1 'column with values (for sum)
destCol = 4 'destination for calculated values
t = Timer
Set ws = Sheets("DBALL")
Set rng = ws.Range("A1").CurrentRegion
n = rng.Rows.Count - 1
Set rng = rng.Offset(1, 0).Resize(n) 'exclude headers
'build the formula to create the row "key"
For i = 0 To UBound(keyCols)
frm = frm & sep & rng.Columns(keyCols(i)).Address
sep = "&""|""&"
Next i
arr = ws.Evaluate(frm) 'get an array of composite keys by evaluating the formula
arrValues = rng.Columns(valueCol).Value 'values to be summed
ReDim arrOut(1 To n, 1 To 1) 'this is for the results
Set dict = CreateObject("scripting.dictionary")
'first loop over the array counts the keys
For i = 1 To n
v = arr(i, 1)
If Not dict.exists(v) Then dict(v) = Array(0, 0) 'count, sum
tmp = dict(v) 'can't modify an array stored in a dictionary - pull it out first
tmp(0) = tmp(0) + 1 'increment count
tmp(1) = tmp(1) + arrValues(i, 1) 'increment sum
dict(v) = tmp 'return the modified array
Next i
'second loop populates the output array from the dictionary
For i = 1 To n
arrOut(i, 1) = dict(arr(i, 1))(1) 'sumifs
'arrOut(i, 1) = dict(arr(i, 1))(0) 'countifs
'arrOut(i, 1) = dict(arr(i, 1))(1) / dict(arr(i, 1))(0) 'averageifs
Next i
'populate the results
rng.Columns(destCol).Value = arrOut
Debug.Print "Checked " & n & " rows in " & Timer - t & " secs"
End Sub
Source
RESULT
As said in the comments a better solution is probably to use a pivot table resp. power pivot.
If you are after a solution with VBA and want to use a dictionary I would probably use the following code.
First you need to create a class cVal which stores the values you are after
Option Explicit
Public qtyIn As Double
Public qtyOut As Double
Then you can use the following code
Option Explicit
Sub useDict()
Const COL_VAL = 1
Const COL_INOUT = 2
Const COL_COMBINE = 3
Const GRO_IN = "IN"
Const GRO_OUT = "OUT"
Dim rg As Range, ws As Worksheet
' Get the range with the data
Set ws = Worksheets("DBALL")
Set rg = ws.Range("A1").CurrentRegion
Set rg = rg.Offset(1, 0).Resize(rg.Rows.Count - 1)
Dim vDat As Variant
vDat = rg
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim Key As Variant, gro As Variant
Dim i As Long, sngVal As cVal
For i = LBound(vDat, 1) To UBound(vDat, 1)
' Key of the dictionary
Key = vDat(i, COL_COMBINE)
' trim the value and do not consider upper/lower case
gro = UCase(Trim(vDat(i, COL_INOUT)))
If dict.Exists(Key) Then
' just increase the "member" values of the already stored object
Set sngVal = dict(Key)
With sngVal
If gro = GRO_IN Then
.qtyIn = .qtyIn + vDat(i, COL_VAL)
End If
If gro = GRO_OUT Then
.qtyOut = .qtyOut + vDat(i, COL_VAL)
End If
End With
Else
' Create a new object which stores the summed values for "IN" resp "OUT"
Set sngVal = New cVal
With sngVal
If gro = GRO_IN Then
.qtyIn = vDat(i, COL_VAL)
End If
If gro = GRO_OUT Then
.qtyOut = vDat(i, COL_VAL)
End If
End With
dict.Add Key, sngVal
End If
Next i
' write Dictionary
' put the values of the dictionary in an array
' this is faster than writing each single line directly to the sheet
ReDim vDat(1 To dict.Count, 1 To 4)
i = 1
For Each Key In dict.Keys
vDat(i, 1) = Key
vDat(i, 2) = dict(Key).qtyIn
vDat(i, 3) = dict(Key).qtyOut
vDat(i, 4) = Abs(dict(Key).qtyIn - dict(Key).qtyOut)
i = i + 1
Next Key
'write Header
Set rg = Worksheets("RECON").Range("A1")
Set rg = rg.Resize(, 4)
rg.Clear
rg = Array("COMBINE", "In", "Out", "Diff")
Set rg = Worksheets("RECON").Range("A2")
Set rg = rg.Resize(dict.Count, 4)
rg.Clear
rg = vDat
' PS Code to add a sum row below the data
Set rg = Worksheets("RECON").Range("A" & dict.Count + 2)
Set rg = rg.Resize(1, 4)
rg.Clear
'rg.Columns(1).Value = "Total"
Dim bSum As Double, rDat As Variant
rDat = Application.Index(vDat, , 2)
bSum = WorksheetFunction.sum(rDat)
rg.Columns(2).Value = bSum
rDat = Application.Index(vDat, , 3)
bSum = WorksheetFunction.sum(rDat)
rg.Columns(3).Value = bSum
rDat = Application.Index(vDat, , 4)
bSum = WorksheetFunction.sum(rDat)
rg.Columns(4).Value = bSum
End Sub
But I doubt that to be faster than a Pivot Table

How to determine the MAX value of a sub-group in a VBA Array

MY APOLOGIES: the code snipet below can induce in error that i work from a worksheet - I got the values in the code from a worksheet only to lighten the code. The VALUES are from an ADODB dataset that is then copied to an array. The values are to stay in memory and no worksheets are to be used to get the end result. so sorry not to have specified this from the start.
I have a 2-dimensional array and I am trying to get the MAX(VALUE) for each unique IDs
ID
VALUE
DATA
101
10
1125
101
8
2546
101
11
1889
102
5
3521
102
10
2254
103
11
3544
the end result should be a finalArr with the unique IDs:
ID
VALUE
DATA
101
11
1889
102
10
2254
103
11
3544
What I have so far:
I did manage to find the MAX in a specific dimension (Value)
Sub MX_Value()
Dim dataArr, iMax As Long, iCount As Long, tmpArr() As Integer, MyDim As Integer
Dim i As Integer
'*NOTE: Values from worksheet is an example only
'in real-life the data comes from an ADODB dataset
'so i need code that works in memory only.
dataArr = ThisWorkbook.Sheets(1).[A1:C6].Value
ReDim tmpAr(1 To UBound(dataArr))
MyDim = 2 'Desired Dimension, 1 to 2
For i = 1 To UBound(dataArr)
tmpAr(i) = dataArr(i, MyDim)
Next
iMax = WorksheetFunction.Max(tmpAr)
iCount = WorksheetFunction.Match(iMax, tmpAr, 0)
MsgBox "MAX value is in dataArr(" & iCount & ") - with data: " & dataArr(iCount, 1) & " - " & dataArr(iCount, 2) & " - " & dataArr(iCount, 3)
End Sub
but I can't figure out how to group the individual IDs to find their MAX. The only logic I can come up with would be to:
Get first ID, then add all rows with the same ID to a tempArr
Send tempArr to a Function to get the MAX and copy the MAX row to a finalArr
Go to next ID not matching the previous one and start again... [???]
Note: in the code example the data is from a worksheet, but only to simplify the code. In it's real-world application, the data in the array comes from an ADODB dataset - so everything must be done in memory
Any insights would be greatly appreciated!
You can use a dictionary to keep track of the maximum values, see example below.
This is the class module called "Record"
Public id As Integer
Public value As Integer
Public data As Integer
Here's the code for the button click I wired up on the sheet
Sub Button3_Click()
Dim dict 'Create a variable
Set dict = CreateObject("Scripting.Dictionary")
Dim dataArr() As Variant
Dim id, value, data As Integer
dataArr = Range("A2:C7").value
Dim rec As Record
For i = 1 To UBound(dataArr)
id = dataArr(i, 1)
value = dataArr(i, 2)
data = dataArr(i, 3)
If (dict.Exists(id)) Then
Set rec = dict(id)
' if value is greater, then update it in dictionary for this id
If (value > rec.value) Then
dict.Remove (rec.id)
Set rec = New Record
rec.id = id
rec.value = value
rec.data = data
dict.Add id, rec
End If
Else
' this is an id we haven't seen before, so add rec to dictionary
Set rec = New Record
rec.id = id
rec.value = value
rec.data = data
dict.Add id, rec
End If
Next
' print results
Dim result As String
For Each id In dict.Keys()
Set rec = dict(id)
result = result & "id = " & id & ", maxValue = " & rec.value & ", data = " & rec.data & vbCrLf
Next
MsgBox (result)
End Sub
Get Maximum of Each Unique Value
The dictionary will hold the unique value as its key, and the row of the highest value as the corresponding item. While looping, it will use this item to compare the values of the 2nd column and modify it accordingly. In the end, another loop will write the results to the same array which will partially be copied to the destination range.
One row of headers is assumed. If you don't want the headers, then change the sfcAddress if necessary and change For r = 1 to srCount and r = 0.
Option Explicit
Sub MaxOfUnique()
Const sName As String = "Sheet1"
Const sfcAddress As String = "A1"
Const dName As String = "Sheet1"
Const dfcAddress As String = "E1"
Const cCount As Long = 3
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sfcAddress)
Dim srg As Range
With sfCell.CurrentRegion
Set srg = sfCell.Resize(.Row + .Rows.Count _
- sfCell.Row, .Column + .Columns.Count - sfCell.Column)
End With
Dim srCount As Long: srCount = srg.Rows.Count
If srCount < 2 Then Exit Sub
Dim Data As Variant: Data = srg.Value
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long
For r = 2 To srCount
If dict.Exists(Data(r, 1)) Then
If Data(r, 2) > Data(dict(Data(r, 1)), 2) Then
dict(Data(r, 1)) = r
End If
Else
dict(Data(r, 1)) = r
End If
Next r
Dim Key As Variant
r = 1
For Each Key In dict.Keys
r = r + 1
Data(r, 1) = Key
Data(r, 2) = Data(dict(Key), 2)
Data(r, 3) = Data(dict(Key), 3)
Next Key
With wb.Worksheets(dName).Range(dfcAddress).Resize(, cCount)
.Resize(r).Value = Data ' write
.Resize(.Worksheet.Rows.Count - .Row - r + 1).Offset(r).Clear ' below
End With
End Sub

VBA Dynamic Array without empty space

I have two arrays: in the first one are names and in the second one there are country codes like this example:
array1(0)="Peter" array2(0)="EN"
array1(1)="John" array2(1)="US"
array1(2)="Sandra" array2(2)="FR"
array1(3)="Margot" array2(3)="DE"
Now, I want to check the from an entry in a textbox1 if its a "FR" available in my arrays,if yes then save the positions in a third new array.
My code looks like this, but it is very bad and it does not work the way I want.
Dim name(0 To 9) As String
array1(0) = "Peter"
array1(1) = "John"
array1(2) = "Sandra"
array1(3) = "Margot"
Dim county(0 To 9)
county(0) = "EN"
county(1) = "US"
county(2) = "FR"
county(3) = "DE"
'Dim ArrayCounter
ArrayCounter = 0
Dim VarArray(9999)
For i = 0 To 9
If county(i) = "DE" Then
'ArrayCounter = ArrayCounter + 1
'MsgBox (array1(i))
VarArray(ArrayCounter) = i
ArrayCounter = ArrayCounter + 1
End If
Next i
MsgBox (UBound(VarArray))
Now, if I check the third array, the array has to look like this:
array3(0)=2 'position of FR in my second array
You can get rid of the empty values in your 0 To 9999 array by redimming it:
If ArrayCounter > 0 Then
ReDim Preserve varArray(0 to ArrayCounter - 1) 'Preserve is important because otherwise it will delete the values
Else
'do what you want to do if no match was found
End If
you may be after the following:
Sub main()
Dim names(0 To 9) As String
names(0) = "Peter"
names(1) = "John"
names(2) = "Sandra"
names(3) = "Margot"
Dim county(0 To 9) As String
county(0) = "EN"
county(1) = "US"
county(2) = "FR"
county(3) = "DE"
Dim ArrayCounter As Long
ArrayCounter = 0
Dim foundArray As Variant
foundArray = county '<--| "copy" the 'county' array into 'foundArray', since this latter won't be bigger than the former
Dim iFound As Long, iCounty As Long
iFound = -1
For iCounty = LBound(county) To UBound(county)
If county(iCounty) = "DE" Then
iFound = iFound + 1 '<-- update the 'foundArray' current counter
foundArray(iFound) = iCounty '<-- update the 'foundArray' current counter content
End If
Next iCounty
If iFound >= 0 Then
ReDim Preserve foundArray(0 To iFound) '<--| if any values have been found, resize 'foundArray' up to the found items counter
Else
Erase foundArray '<--| otherwise erase it
End If
End Sub

Efficient method to use excel checksheet data to create and populate a list in a new sheet

I am working on a project, which takes a checksheet that the user creates and fills out
and, when the user runs a macro, creates a new workbook that extrapolates and expands the checksheet data, as shown here
What it does is it goes through each of those number labor codes, and runs down the checksheet for all the applicable items, addending them to the list.
Now...I have this working fine, and run through the basic testing. I save the checksheet as an array and pass it through to the new workbook, filtering and creating the new workbook line-by-line.
I just can't help but think that there's a much easier way to do this, as the way I'm doing it now just doesn't seem to be the simplest and most stable way.
I'm open to sharing my code I have so far, but was wondering if you were given this senario, how you would approach it.
Here is the link to my file: https://www.dropbox.com/s/2gobdx1rcabquew/Checksheet_Template_R3.0%20-%20StkOvrflw.xls
Main module, which checks for errors and corrects formatting:
Option Explicit
Public FamilyName As String
Public ModelName As String
Public TaskArray() As Variant
Public TaskArrayRowCount As Integer
Public TaskArrayColCount As Integer
Sub CreateTemplate()
Application.EnableEvents = False
Application.ScreenUpdating = False
'Main SubModule. Runs Formatting and Template Generation
Dim thisWB As Workbook
Dim TaskArray() As Variant
Dim i As Range
Dim MajMinYesNo As Boolean
Dim OPOYesNo As Boolean
If MsgBox("Are you ready to generate the Template?", vbYesNo, "Ready?") = vbNo Then
Application.EnableEvents = True
Application.ScreenUpdating = True
End
End If
MajMinYesNo = False
OPOYesNo = False
Set thisWB = ActiveWorkbook
FamilyName = thisWB.Names("Family_Name").RefersToRange
ModelName = thisWB.Names("Model_No").RefersToRange
Call CreateArray(thisWB)
'Scans Form_Type Column for "R", "S", or "A-E"
For Each i In Range("CS_FormType")
If i Like "[RS]" Then
MajMinYesNo = True
ElseIf i Like "[A-E]" Then
OPOYesNo = True
End If
Next
'Generates Templates As Needed
If MajMinYesNo Then
If MsgBox("Generate Major/Minor Template?", vbYesNo) = vbYes Then
Call MajorMinor_Generate.GenerateMajorMinor(thisWB)
End If
End If
If OPOYesNo Then
If MsgBox("Generate OPO Template?", vbYesNo) = vbYes Then
Call OPO_Generate.GenerateOPO(thisWB)
End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox ("DONE!")
End Sub
Sub CreateArray(thisWB As Workbook)
'Checks formatting and creates array TaskArray() with all the checksheet data
With thisWB.Sheets(1)
'Confirms equal number of rows in columns "CS_TaskNo", "CS_FormType", and "CS_Task"
If (Not Range("CS_TaskNo").Rows.count = Range("CS_FormType").Rows.count) _
Or (Not Range("CS_TaskNo").Rows.count = Range("CS_Task").Rows.count) Then
MsgBox ("Task_No, Form_Type, and Task_Desc row count does not match. Please fix and try again")
Application.EnableEvents = True
Application.ScreenUpdating = True
End
End If
Call FormatCheck
Application.Union(Range("CS_Heading"), Range("CS_TaskNo"), Range("CS_FormType"), Range("CS_Task"), Range("CS_LaborCodes"), Range("CS_Checks")).Name = "TaskArray"
TaskArrayRowCount = Range("TaskArray").Rows.count
TaskArrayColCount = Range("TaskArray").Columns.count
ReDim TaskArray(TaskArrayRowCount, TaskArrayColCount)
TaskArray = Range("TaskArray").Value
End With
End Sub
Sub FormatCheck()
'Checks for valid labor codes and Form Types
If (Not CheckFormType()) Or (Not CheckLC()) Then
MsgBox ("Errors found, please check red-highlighted cells")
Application.EnableEvents = True
Application.ScreenUpdating = True
End
End If
End Sub
Function CheckFormType()
'Returns False if there's a bad Form_Type entry in range "CS_FormType", True if all OK
Dim i As Range
Dim ReturnVal As Boolean
ReturnVal = True
For Each i In Range("CS_FormType")
Trim (UCase(i.Value))
If Not (i Like "[ABCDEFRS]") Then
Highlight (Cells(i.Row, i.Column))
ReturnVal = False
End If
Next
CheckFormType = ReturnVal
End Function
Function CheckLC()
'Returns False if there's a bad error code, True if all OK _
Formats labor code ranges to add spaces as needed and checks _
labor codes for proper format (###X or ##X). Skips any labor _
codes starting with "28X"
Dim LaborCode As String
Dim LaborCodeLength As Integer
Dim i As Range
Dim j As Integer
Dim LCCell As Range
Dim LCArray() As String
Dim ReturnVal As Boolean
ReturnVal = True
For Each i In Range("CS_LaborCodes")
Trim (UCase(i.Value))
LaborCode = i.Value
If Not Left(LaborCode, 3) Like "28?" Then
LaborCodeLength = Len(LaborCode)
'If string LaborCode is > 4, safe to assume it is a range of labor codes 123A-123F
Select Case LaborCodeLength
Case Is > 4
'Formats Labor Code Range String by adding spaces if necessary (i.e. 123A-123F to 123A - 123F)
For j = 2 To LaborCodeLength Step 1
If (IsNumeric(Mid(LaborCode, j, 1))) And Not IsNumeric(Mid(LaborCode, j + 1, 1)) And Not (Mid(LaborCode, j + 2, 1) = " ") Then
LaborCode = Left(LaborCode, j + 1) & " " & Mid(LaborCode, j + 2)
ElseIf IsNumeric(Mid(LaborCode, j, 1)) And Not (Mid(LaborCode, j - 1, 1) = " ") And Not IsNumeric(Mid(LaborCode, j - 1, 1)) Then
LaborCode = Left(LaborCode, j - 1) & " " & Mid(LaborCode, j)
End If
Next
i = LaborCode
LCArray = Split(LaborCode, " ")
'confirms the labor codes are valid
If (Not IsLaborCode(LCArray(0))) Or (Not IsLaborCode(LCArray(2))) Or (Not IsLaborCodeRange(LCArray(0), LCArray(2))) Then
Highlight (Cells(i.Row, i.Column))
ReturnVal = False
End If
Case 0 To 4
If Not (IsLaborCode(LaborCode)) Then
Highlight (Cells(i.Row, i.Column))
ReturnVal = False
End If
Case Else
Highlight (Cells(i.Row, i.Column))
ReturnVal = False
End Select
End If
Next
CheckLC = ReturnVal
End Function
Function IsLaborCode(LC As String) As Boolean
'returns True if Labor Code is valid, False if invalid _
Labor Code is valid if it is 2 or 3 numbers followed by a letter _
labor code format : ###X or ##X
If LC Like "###[A-Z]" Or LC Like "##[A-Z]" Then
IsLaborCode = True
Else
IsLaborCode = False
End If
End Function
Function IsLaborCodeRange(LCOne As String, LCTwo As String) As Boolean
'returns True if the LC range is valid, False if invalid. _
checks the numerical values to make sure they match and _
makes sure the letters are ascending
If (StrComp(Left(LCOne, Len(LCOne) - 1), Left(LCTwo, Len(LCTwo) - 1)) = 0) And LCOne < LCTwo Then
IsLaborCodeRange = True
Else
IsLaborCodeRange = False
End If
End Function
And here is the other module which actually takes the array and creates the new workbook:
Sub GenerateMajorMinor(thisWB As Workbook)
Dim newWB As Workbook
Dim MajMinArray() As Variant
Set newWB = Workbooks.Add
With newWB
Call FormatWorkbook
Call CreateMajMinArray(newWB, MajMinArray)
Call PopulateItemMaster(MajMinArray)
Call PopulateLaborLink(MajMinArray)
Call SaveFile(newWB, thisWB)
End With
End Sub
Sub SaveFile(newWB As Workbook, thisWB As Workbook)
'saves new workbook into the same file path as the checksheet
Dim i As Integer
Dim FileSavePath As String
Dim FamNameSave As String
FamNameSave = Replace(FamilyName, "/", "_")
i = 1
FileSavePath = thisWB.Path + "/Template (Minor and Major)_" + FamNameSave + ".xls"
a: If Dir(FileSavePath) <> "" Then
FileSavePath = thisWB.Path + "/Template (Minor and Major)_" + FamNameSave + "(" + CStr(i) + ").xls"
i = i + 1
GoTo a:
End If
newWB.SaveAs FileSavePath, FileFormat:=56
End Sub
Sub FormatWorkbook()
'Names and formats sheets
Sheets(1).Name = "Item_Master"
Sheets(2).Name = "Labor_Link"
With Sheets(1)
.Range("A1") = "Company_No"
.Range("B1") = "Family_Name"
.Range("C1") = "Form_Type"
.Range("D1") = "Record_Status"
.Range("E1") = "Task_Desc"
.Range("F1") = "Task_No"
.Range("G1") = "Task_Seq"
.Range("H1") = "Is_Parametric"
End With
With Sheets(2)
.Range("A1") = "Company_Name"
.Range("B1") = "Family_Name"
.Range("C1") = "Form_Type"
.Range("D1") = "Labor_Code"
.Range("E1") = "Print_Control"
.Range("F1") = "Record_Status"
.Range("G1") = "Task_No"
End With
End Sub
Sub CreateMajMinArray(newWB As Workbook, MajMinArray As Variant)
'creates array, removing any OPO/BTS labor codes
With Sheets(3)
Application.EnableEvents = True
Application.ScreenUpdating = True
Dim rng As Range
Set rng = .Range(.Range("A1"), .Cells(TaskArrayRowCount, TaskArrayColCount))
rng = TaskArray
For i = 1 To .Range("A1").End(xlDown).Row Step 1
If .Cells(i, 2) Like "[A-E]" Then
.Rows(i).Delete
i = i - 1
End If
Next
For i = 1 To .Range("A1").End(xlToRight).Column Step 1
If Left(.Cells(1, i), 3) Like "28E" Then
.Columns(i).Delete
i = i - 1
End If
Next
ReDim MajMinArray(.Range("A1").End(xlDown).Row, .Range("A1").End(xlToRight).Column)
MajMinArray = .Range(.Range("A1"), .Cells(.Range("A1").End(xlDown).Row, .Range("A1").End(xlToRight).Column)).Value
.Cells.Clear
End With
End Sub
Sub PopulateItemMaster(MajMinArray As Variant)
With Sheets(1)
'Populates "Item_Master" Sheet
For i = 2 To UBound(MajMinArray) Step 1
.Cells(i, 2) = FamilyName
.Cells(i, 3) = MajMinArray(i, 2)
.Cells(i, 4) = "1"
.Cells(i, 5) = MajMinArray(i, 3)
.Cells(i, 6) = MajMinArray(i, 1)
.Cells(i, 7) = MajMinArray(i, 1)
Next
End With
End Sub
Sub PopulateLaborLink(MajMinArray As Variant)
Dim i As Integer
Dim LaborCode As String
Dim RowCount As Long
Dim LCArray() As String
Dim LastLetter As String
Dim LastFormType As String
'Initializes RowCount and PrintControl
RowCount = 2
PrintControl = 10
With Sheets(2)
For i = 4 To UBound(MajMinArray, 2) Step 1
LaborCode = Trim(MajMinArray(1, i))
'If Labor Code String length is > 4, safe to assume that it is a range of labor codes
Select Case Len(LaborCode)
Case Is > 4
LCArray = Split(LaborCode, " ")
'checks to see if LCArray(0) and LCArray(2) has values
If LCArray(0) = "" Or LCArray(2) = "" Then
MsgBox ("Error with Labor Code range. Please check and re-run")
Application.EnableEvents = True
Application.ScreenUpdating = True
End
End If
LastLetter = Chr(Asc(Right$(LCArray(2), 1)) + 1)
LCArray(2) = Replace(LCArray(2), Right$(LCArray(2), 1), LastLetter)
Do
Call PrintLaborLinkLines(MajMinArray, LCArray(0), RowCount, i)
LastLetter = Chr(Asc(Right$(LCArray(0), 1)) + 1)
LCArray(0) = Replace(LCArray(0), Right$(LCArray(0), 1), LastLetter)
Loop Until LCArray(0) = LCArray(2)
Erase LCArray()
Case Is <= 4
Call PrintLaborLinkLines(MajMinArray, LaborCode, RowCount, i)
End Select
Next
End With
End Sub
Sub PrintLaborLinkLines(MajMinArray As Variant, LaborCode As String, RowCount As Long, i As Integer)
Dim PrintControl As Long
PrintControl = 10
With Sheets(2)
For x = 2 To UBound(MajMinArray) Step 1
If UCase(MajMinArray(x, i)) = "Y" Then
If LastFormType <> MajMinArray(x, 2) Then
PrintControl = 10
End If
.Cells(RowCount, 2) = FamilyName
.Cells(RowCount, 3) = MajMinArray(x, 2)
.Cells(RowCount, 4) = LaborCode
.Cells(RowCount, 5) = PrintControl
.Cells(RowCount, 6) = "1"
.Cells(RowCount, 7) = MajMinArray(x, 1)
RowCount = RowCount + 1
PrintControl = PrintControl + 10
LastFormType = MajMinArray(x, 2)
End If
Next
End With
End Sub
If restructuring the order of the data on the new sheet is possible it seems as though you could copy only visible cells and then write a simple loop to bring in any data that is not explicit (ie Labor Code).

Resources