VBA Jagged Array Duplicates - arrays

I'm new to coding with VBA, and a beginner programmer in general. I have the following simple table (the data keeps getting inputted on daily basis, so it changes):
Item #
Description
Date
Location
Plate
Load
Type
Rate
Cost
0001
des1
30/1/21
Site
ABC123
5
One
typ1
100
0002
des2
30/1/21
Office
ACB465
4
One
typ1
100
0003
des3
30/1/21
Office
ABC789
3
One
typ1
100
0004
des4
30/1/21
Site
ABS741
5
One
typ1
100
0005
des4
31/1/21
Office
ABC852
2
One
typ1
100
I would like to filter this data by specific date first, then delete duplicates in Location while adding the Load for said duplicates.
For example, if I wanted to filter for 30/1/21. It would end up as follows:
Location
Load
Site
10
Office
7
I would then want to put it in one summary cell as follows:
Summary
10 Site, 7 Office
I was able to filter the original table into jagged arrays. The code for that is:
For j = numberSkipD To numberRowsD
If Worksheets("Disposal Fees").Range("F" & j).Value = Worksheets("Daily Tracking").Range("B2").Value Then
For k = numberDisposalInformationRaw To numberDisposalLocation
ReDim Preserve disposalLocation(numberDisposalLocation)
disposalLocation(numberDisposalLocation) = Worksheets("Disposal Fees").Range("I" & j).Value
Next
numberDisposalLocation = numberDisposalLocation + 1
For k = numberDisposalInformationRaw To numberDisposalLoad
ReDim Preserve disposalLoad(numberDisposalLoad)
disposalLoad(numberDisposalLoad) = Worksheets("Disposal Fees").Range("K" & j).Value
Next
numberDisposalLoad = numberDisposalLoad + 1
End If
Next
I then tried to do the second table above (deleting duplicates and adding the values for said duplicates together) but it is giving me errors, not sure how to solve them. I know they're index errors, but don't know how to fix them. (Please help me with this part, here is the code)
Dim disposalInformationRaw As Variant
Dim disposalInformationCooked As Variant
Dim FoundIndex As Variant, MaxRow As Long, m As Long
ReDim disposalInformationCooked(1 To UBound(disposalInformationRaw, 1), 1 To UBound(disposalInformationRaw, 2))
MaxRow = 0
For m = 1 To UBound(disposalInformationRaw, 1)
FoundIndex = Application.Match(disposalInformationRaw(m, 1), Application.Index(disposalInformationCooked, 0, 1), 0)
If IsError(FoundIndex) Then
MaxRow = MaxRow + 1
FoundIndex = MaxRow
disposalInformationCooked(FoundIndex, 1) = disposalInformationRaw(m, 1)
End If
disposalInformationCooked(FoundIndex, 2) = Val(disposalInformationCooked(FoundIndex, 2)) + Val(disposalInformationRaw(i, 2))
Next m
Range("G1").Resize(MaxRow, UBound(disposalInformationCooked, 2)).Value = disposalInformationCooked
I don't think I'd have much trouble finalizing the third part (the summary), but if you know how to do it, please feel free to share how you would approach it. I mostly need help with the second part. I would be more than happy to edit and provide more information if needed. Thanks in advance.

Here's one approach using a dictionary.
dim dict, rw as range, locn, k, msg, theDate
set dict= createobject("scripting.dictionary")
theDate = Worksheets("Daily Tracking").Range("B2").Value
'adjust table range as required
for each rw in worksheets("Disposal Fees").range("F6:K100").rows
if rw.cells(3).Value = theDate Then 'date match?
locn = rw.cells(4).Value 'read location
dict(locn) = dict(locn) + rw.cells(6).Value 'add load to sum
end if
next rw
'loop over the dictionary keys and build the output
for each k in dict
msg = msg & IIf(len(msg) > 0, ", ", "") & dict(k) & " " & k
next k
debug.print msg

Sum Unique
Disposal Fees
Daily Tracking
Adjust the values in the constants section.
The Code
Option Explicit
Sub TESTsumByValue()
' Source
Const srcName As String = "Disposal Fees"
Const lCol As Long = 3
Const kCol As Long = 4
Const sCol As Long = 6
Const SumFirst As Boolean = True
Const KSDel As String = ":"
Const IDel As String = ", "
' Destination
Const dstName As String = "Daily Tracking"
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
' Define Source Range (You may have to do something different).
Dim srg As Range: Set srg = wb.Worksheets(srcName).Range("A1").CurrentRegion
' Write Criteria to variable.
Dim drg As Range: Set drg = wb.Worksheets(dstName).Range("B2")
Dim Criteria As Variant: Criteria = drg.Value
' Use function to get the result.
Dim s As String
s = sumByValue(Criteria, srg, lCol, kCol, sCol, SumFirst, KSDel, IDel)
Debug.Print s ' "10:Site, 4:Bathroom, 4:Office"
drg.Offset(, 3).Value = s ' writes to 'E2'
End Sub
Function sumByValue( _
ByVal LookupValue As Variant, _
rng As Range, _
ByVal LookupColumn As Long, _
ByVal KeyColumn As Long, _
ByVal SumColumn As Long, _
Optional ByVal SumFirst As Boolean = False, _
Optional ByVal KeySumDelimiter As String = ": ", _
Optional ByVal ItemsDelimiter As String = ", ") _
As String
' Validate range ('rng').
If rng Is Nothing Then Exit Function
' Write values from range to Data Array ('Data').
Dim Data As Variant: Data = rng.Value ' 2D one-based array
' Declare additional variables.
Dim vKey As Variant ' Current Key Value
Dim vSum As Variant ' Current Sum Value
Dim i As Long ' Data Array Row Counter
' Create a reference to Unique Sum Dictionary (no variable).
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare ' 'A = a'
' Loop through Data Array ('Data') and write and sumup unique values
' to Unique Sum Dictionary.
For i = 1 To UBound(Data, 1)
If Data(i, LookupColumn) = LookupValue Then
vKey = Data(i, KeyColumn)
If Not IsError(vKey) Then
If Len(vKey) > 0 Then
vSum = Data(i, SumColumn)
If IsNumeric(vSum) Then
.Item(vKey) = .Item(vKey) + vSum
Else
.Item(vKey) = .Item(vKey) + 0
End If
End If
End If
End If
Next i
' Validate Unique Sum Dictionary.
If .Count = 0 Then Exit Function
' Redefine variables to be reused.
ReDim Data(1 To .Count) ' Result Array: 1D one-based array
i = 0 ' Result Array Elements Counter
' Write results to Result Array.
If SumFirst Then
For Each vKey In .Keys
i = i + 1
Data(i) = .Item(vKey) & KeySumDelimiter & vKey
Next vKey
Else
For Each vKey In .Keys
i = i + 1
Data(i) = vKey & KeySumDelimiter & .Item(vKey)
Next vKey
End If
End With
' Write the elements of Data Array to Result String.
sumByValue = Join(Data, ItemsDelimiter)
End Function

Related

VBA 2D Array for each item find average value

I am trying to find a way to average an array column value with a condition on items from another column in that array - I am aware that a class or dictionary might be the best solution but I would like to stick to an array as in my real scenario I have to use an array.
In this case the data is as follows
Risk ID Data set 1 Data set 2
23359720 1154 587
23359720 1254 658
23359720 854 756
23293773 965 1456
20053692 1458 458
I would like to find the average of Data sets 1 and 2 per Risk ID, here is what I've tried but does not work - I have seen that this it's not possible to use for each and point it to a specific column, but not sure what else to do in the case of an array?
Edit: expected result data:
ArrayResultAverage()
Risk ID Avg Data set 1 Avg Data set 2
23359720 1087.33 667
23293773 965 1456
20053692 1458 458
Sub Test_Arr_Avg()
'
Dim TESTWB As Workbook
Dim TESTWS As Worksheet
Set TESTWB = ThisWorkbook
Set TESTWS = TESTWB.Worksheets("TEST")
'Array set up
Dim RngTest As Range
Dim ArrTestAvg As Variant
NbRowsTest = TESTWS.Range("A1").End(xlDown).Row
Set RngTest = TESTWS.Range(TESTWS.Cells(1, 1), TESTWS.Cells(NbRowsTest, 3))
ArrTestAvg = RangeToArray2D(RngTest)
'Find the average of Data Range 1 for each item in Risk ID
For k = 1 To UBound(ArrTestAvg, 1)
Dim Sum As Variant
Sum = 0
For Each Item In ArrTestAvg(k, 1)
Sum = Sum + ArrTestAvg(k, 2)
Dim AverageDataSet1 As Variant
AverageDataSet1 = Sum / UBound(ArrTestAvg(Item)) + 1
Debug.Print AverageDataSet1
Next Item
Next k
End Sub
Public Function RangeToArray2D(inputRange As Range) As Variant()
Dim size As Integer
Dim inputValue As Variant, outputArray() As Variant
inputValue = inputRange
On Error Resume Next
size = UBound(inputValue)
If Err.Number = 0 Then
RangeToArray2D = inputValue
Else
On Error GoTo 0
ReDim outputArray(1 To 1, 1 To 1)
outputArray(1, 1) = inputValue
RangeToArray2D = outputArray
End If
On Error GoTo 0
End Function
Get Averages of Unique Data
Adjust the values in the constants section, especially the destination worksheet name (it's the same as the source worksheet name) and its first cell address.
The dictionary's keys hold the unique risk ids, while its items (values) hold the associated destination rows.
The result is written to the same array (which is too big) but with dr the destination row size is tracked and only three columns will be copied.
Before the calculation of the averages, column 1 holds the unique risk ids (the same order as in the dictionary), columns 2 and 3 hold the sums while columns 4 and 5 hold the counts of the first and second data set respectively.
Option Explicit
Sub Test_Arr_Avg()
' Source
Const sName As String = "Sheet1"
' Destination
Const dName As String = "Sheet1"
Const dFirstCellAddress As String = "E1"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Read from source.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
Dim srg As Range: Set srg = sws.Range("A1", sws.Cells(slRow, "C"))
Dim srCount As Long: srCount = srg.Rows.Count
' Write source range values to array.
Dim Data As Variant: Data = GetRange(srg)
' Add two helper columns for the count.
ReDim Preserve Data(1 To srCount, 1 To 5)
' Sum up and count uniques.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim dr As Long: dr = 1 ' first row are headers
Dim sr As Long
Dim cr As Long
Dim c As Long
For sr = 2 To srCount
' Sum up.
If dict.Exists(Data(sr, 1)) Then
cr = dict(Data(sr, 1))
For c = 2 To 3
Data(cr, c) = Data(cr, c) + Data(sr, c)
Next c
Else
dr = dr + 1
cr = dr
dict(Data(sr, 1)) = cr
For c = 1 To 3
Data(cr, c) = Data(sr, c)
Next c
End If
' Count.
For c = 4 To 5
Data(cr, c) = Data(cr, c) + 1
Next c
Next sr
' Calculate averages.
For cr = 2 To dr
For c = 2 To 3
Data(cr, c) = Data(cr, c) / Data(cr, c + 2)
' You might want to round the results instead:
'Data(cr, c) = Round(Data(cr, c) / Data(cr, c + 2), 2)
Next c
Next cr
Application.ScreenUpdating = False
' Write to destination.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
With dws.Range(dFirstCellAddress).Resize(, 3)
.Resize(dr).Value = Data
' Clear below.
.Resize(dws.Rows.Count - .Row - dr + 1).Offset(dr).Clear
' Apply various formatting.
.Font.Bold = True ' headers
.Resize(dr - 1, 2).Offset(1, 1).NumberFormat = "#0.00" ' averages
.EntireColumn.AutoFit ' columns
End With
'wb.Save
' Inform.
Application.ScreenUpdating = True
MsgBox "Risk ids averaged.", vbInformation
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
Const ProcName As String = "GetRange"
On Error GoTo ClearError
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
It would be complicated to use a single Dictionary. Here I add a Sub-Dictionary for each Risk ID to the main Dictionary. The Sub-Dictionary is used to hold all the values for each ID. The final step is to create an array of averages for all the main Dictionary items.
Sub Test_Arr_Avg()
Dim Data As Variant
With TestWS.Range("A1").CurrentRegion
Data = .Offset(1).Resize(.Rows.Count - 1, 3)
End With
Dim Results As Variant
Results = KeyedAverages(Data, 1, 2)
Stop
End Sub
Function KeyedAverages(Data As Variant, IDColumn As Long, ValueColumn As Long)
Dim Map As Object
Set Map = CreateObject("Scripting.Dictionary")
Dim Key As Variant
Dim r As Long
For r = 1 To UBound(Data)
Key = CStr(Data(r, IDColumn))
If Len(Key) > 0 Then
If Not Map.Exists(Key) Then Map.Add Key, CreateObject("Scripting.Dictionary")
With Map(Key)
.Add CStr(.Count), Data(r, ValueColumn)
End With
End If
Next
Dim Results As Variant
Dim Values As Variant
ReDim Results(1 To Map.Count, 1 To 2)
Dim n As Long
For Each Key In Map.Keys
n = n + 1
Values = Map(Key).Items
Results(n, 1) = Key
Results(n, 2) = WorksheetFunction.Average(Values)
Next
KeyedAverages = Results
End Function
Public Function TestWB() As Workbook
Set TestWB = ThisWorkbook
End Function
Public Function TestWS() As Worksheet
Set TestWS = TestWB.Worksheets("Test")
End Function
Note: Code updated to exclude empty items.

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 Copy row from one 2D array and add it to another 2D array

I have a large database (~7000 rows x 25 columns) that i have assigned to an array. Based on user inputs, I am trying to search the database to find items that match the input and copy the entire row to a new array to create a new database to filter with the next question. The arrays are DBRange and DBT and are defined as public variants. I've tried copying the data from DBRange to a new sheet, but that is incredibly slow and I'm trying to speed things up with keeping things within arrays if possible.
DBRange = wsd.Range("A1").CurrentRegion 'Sets DBRange to the entirety of the Database
Cervical = 0
If CervicalStartOB.Value = True Then
Cervical = 1
SpineSection.Hide
For i = LBound(DBRange, 1) To UBound(DBRange, 1) 'starts for loop starting with the 1st row in the array to the last row
If DBRange(i, 13) = "X" Then 'determines if the value in row i column 13 has an X
ReDim Preserve DBT(count, UBound(DBRange, 2))
DBT(count, UBound(DBRange, 2)) = Application.WorksheetFunction.Index(DBRange, i, 0)
count = count + 1
End If
Next i
Get Range Criteria Rows
Option Explicit
Sub GetRangeCriteriaRowsTESTKeepHeaders()
Const sCriteriaString As String = "X"
Const sCol As Long = 13
Const sfRow As Long = 2 ' First Data Row
Dim wsd As Worksheet: Set wsd = ActiveSheet
' Reference the source range
Dim srg As Range: Set srg = wsd.Range("A1").CurrentRegion
' Write the criteria rows to an array.
' If you want to keep headers, use the first row ('sfrow')
' as the parameter of the 'FirstRow' argument of the function.
Dim DBT As Variant
DBT = GetRangeCriteriaRows(srg, sCriteriaString, sCol, sfRow)
If IsEmpty(DBT) Then Exit Sub
End Sub
Sub GetRangeCriteriaRowsTESTOnlyData()
Const sCriteriaString As String = "X"
Const sCol As Long = 13
Const sfRow As Long = 2 ' First Data Row
Dim wsd As Worksheet: Set wsd = ActiveSheet
' Reference the source range.
Dim srg As Range: Set srg = wsd.Range("A1").CurrentRegion
' Reference the data range (no headers).
Dim shrCount As Long: shrCount = sfRow - 1
Dim sdrg As Range
Set sdrg = srg.Resize(srg.Rows.Count - shrCount).Offset(shrCount)
' Write the criteria rows to an array.
' If the range has no headers, don't use the 'FirstRow' argument
' of the function.
Dim DBT As Variant: DBT = GetRangeCriteriaRows(sdrg, sCriteriaString, sCol)
If IsEmpty(DBT) Then Exit Sub
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of the rows of a range ('SourceRange'),
' that meet a string criterion ('CriteriaString') in a column
' ('CriteriaColumnIndex'), in a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRangeCriteriaRows( _
ByVal SourceRange As Range, _
ByVal CriteriaString As String, _
Optional ByVal CriteriaColumnIndex As Long = 1, _
Optional ByVal FirstRow As Long = 1) _
As Variant
Const ProcName As String = "GetRangeCriteriaRows"
On Error GoTo ClearError
' Count the source rows and the source/destination columns.
Dim srCount As Long: srCount = SourceRange.Rows.Count
Dim cCount As Long: cCount = SourceRange.Columns.Count
' Count the source header rows.
Dim shrCount As Long: shrCount = FirstRow - 1
' Define the source data range according to the first row.
Dim sdrg As Range
Set sdrg = SourceRange.Resize(srCount - shrCount).Offset(shrCount)
' Write the source range values to the source array.
Dim sData As Variant: sData = SourceRange.Value
' Count the criteria rows in the source data criteria column range.
Dim sdcrg As Range: Set sdcrg = sdrg.Columns(CriteriaColumnIndex)
Dim drCount As Long
drCount = Application.CountIf(sdcrg, CriteriaString) + shrCount
' Define the destination array.
Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
Dim sr As Long ' Current Source Row
Dim c As Long ' Current Source/Destination Column
Dim dr As Long ' Current Destination Row
' Write the header rows from the source array to the destination array.
If FirstRow > 1 Then
For sr = 1 To shrCount
dr = dr + 1
For c = 1 To cCount
dData(dr, c) = sData(sr, c)
Next c
Next sr
End If
' Write the criteria rows from the source array to the destination array.
For sr = FirstRow To srCount
If StrComp(CStr(sData(sr, CriteriaColumnIndex)), CriteriaString, _
vbTextCompare) = 0 Then
dr = dr + 1
For c = 1 To cCount
dData(dr, c) = sData(sr, c)
Next c
End If
Next sr
GetRangeCriteriaRows = dData
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function

Make a new array that contains only selected rows from a previous array based on a variable in a column

I'm trying to make a new array that contains only selected values from a previous array based on a variable.
For instance, I have this as an array:
Using a selection box from a user form, I want to be able to pick item # 15 for instance (in column 1) and get a new array of just the rows that contain item # 15 (new array would be 3 rows by 9 columns).
any ideas how to do that? also allowing it to be dynamic since I want to be able to do this for different sets of Data. I'm not sure if it would be better to sort on two columns column 1 which is item # and the last column that corresponds to what sheet it is on.
Please try this code. It should be installed in a standard code module. Adjust the enumerations at the top to show where the data are (presumed to be at A2:I13). The code asks you to specify an Item to extract and will print the extracted data to an area 5 rows below the original.
Option Explicit
Enum Nws ' worksheet navigation
' modify as required
NwsFirstDataRow = 2
' columns and Array elements:-
NwsItm = 1 ' indicate column A
NwsTab = 9 ' indicate column I
End Enum
Sub Test_DataSelection()
Dim Ws As Worksheet
Dim Rng As Range
Dim Arr As Variant
Dim Itm As String
Set Ws = ThisWorkbook.Worksheets("Sheet1") ' modify as required
With Ws
Set Rng = .Range(.Cells(NwsFirstDataRow, NwsItm), _
.Cells(.Rows.Count, NwsTab).End(xlUp))
End With
Arr = Rng.Value
Itm = InputBox("Enter a valid Item number", "Select data", 5)
Arr = SelectedData(Itm, Arr)
With Ws ' may specify another sheet here
Set Rng = .Cells(.Rows.Count, NwsItm).End(xlUp).Offset(5)
Rng.Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr
End With
End Sub
Function SelectedData(ByVal Itm As Variant, _
Arr As Variant) As Variant()
' Variatus #STO 21 Jan 2020
Dim Fun() As Variant
Dim Ub As Long
Dim i As Long
Dim R As Long, C As Long
On Error Resume Next
Ub = UBound(Arr)
If Err.Number = 0 Then
On Error GoTo 0
Itm = Val(Itm)
ReDim Fun(1 To UBound(Arr, 2), 1 To Ub)
For R = 1 To Ub
If Arr(R, 1) = Itm Then
i = i + 1
For C = 1 To UBound(Arr, 2)
Fun(C, i) = Arr(R, C)
Next C
End If
Next R
ReDim Preserve Fun(1 To UBound(Fun), 1 To i)
End If
SelectedData = Application.Transpose(Fun)
End Function
HerLow
A basic idea that you might be able to adapt to your needs…..to answer this …. I want to be able to pick item # 15 for instance (in column 1) and get a new array of just the rows that contain item # 15 (new array would be 3 rows by 9 columns).
Option Explicit
Sub ArrayBasedOnRowSelection()
Dim WsList As Worksheet, WsOut As Worksheet
Set WsList = ThisWorkbook.Worksheets("List"): Set WsOut = ThisWorkbook.Worksheets("Output")
Dim arrIn() As Variant, arrOut() As Variant
Let arrIn() = WsList.UsedRange
Dim Cnt As Long, strRws As String
For Cnt = 2 To WsList.UsedRange.Rows.Count
If arrIn(Cnt, 1) = "15" Then
Let strRws = strRws & Cnt & " "
Else
End If
Next Cnt
Let strRws = Left$(strRws, Len(strRws) - 1)
Dim SptStr() As String: Let SptStr() = Split(strRws, " ", -1, vbBinaryCompare)
Dim RwsT() As String: ReDim RwsT(1 To UBound(SptStr()) + 1, 1 To 1)
For Cnt = 1 To UBound(SptStr()) + 1
Let RwsT(Cnt, 1) = SptStr(Cnt - 1)
Next Cnt
Dim Clms() As Variant: Let Clms() = Evaluate("=Column(A:" & CL(WsList.UsedRange.Columns.Count) & ")") ' Evaluate("=Column(A:I)")
Let arrOut() = Application.Index(arrIn(), RwsT(), Clms())
WsOut.Cells.Clear
Let WsOut.Range("A2").Resize(UBound(arrOut(), 1), WsList.UsedRange.Columns.Count).Value = arrOut
End Sub
' http://www.excelfox.com/forum/showthread.php/1902-Function-Code-for-getting-Column-Letter-from-Column-Number?p=8824&viewfull=1#post8824
Public Function CL(ByVal lclm As Long) As String ' http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
Do: Let CL = Chr(65 + (((lclm - 1) Mod 26))) & CL: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function
If you run that macro , it will paste out an array 3 rows by as many columns as your used range in worksheet “List”, based on the selection 15 from column 1.
File: ArrayfromRowsBasedOnPreviousArray.xlsm : https://app.box.com/s/h9ipfz2ngskjn1ygitu4zkqr1puuzba1
Explanation : https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172
Alan

Looping through an array while grabbing certain elements

I have a giant dataset that looks like this
I am trying to go down the list of different companies and grab 3 per company and combine them. Based on the photo above, I would have 2 different lists with 3 companies each (except TH Repair which will have 2 in the final list).
My real dataset contains hundreds of different companies, each with dozens/hundreds of entries so I would finish with dozens of lists (each potentially hundreds long).
I tried to record a macro and ended up with this code
Sub Loop1()
'
' Loop1 Macro
'
'
Range("A4:E6").Select
Selection.Copy
Sheets("Sheet3").Select
Range("A18").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("A11:E13").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A21").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("A17:E19").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A24").Select
ActiveSheet.Paste
End Sub
However, this turned out to be WAY more complicated then I expected.
I am looking for the end result to look like this
See if something like this works for you. I only ran one scenario through it so you will want to test it more.
This makes the assumption that the data is sorted by column B on the original sheet
This procedure makes an assumption that there is either headers or no data on row 1.
You will need to change the "Sheet1" in this line Set ws1 = ActiveWorkbook.Worksheets("Sheet1") to the name of the sheet you are starting with.
Option Explicit
Public Sub MoveData()
Dim ws1 As Worksheet
Set ws1 = ActiveWorkbook.Worksheets("Sheet1")
Dim ws2 As Worksheet
Set ws2 = ActiveWorkbook.Worksheets.Add()
Dim rw As Long
Dim match_count As Integer
Dim list_multiplier As Integer
list_multiplier = 7
Dim list_row() As Long
ReDim list_row(0)
list_row(0) = 2
For rw = 2 To ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
If ws1.Range("B" & rw).Value <> ws1.Range("B" & rw).Offset(-1, 0).Value Then
match_count = 0
Else
match_count = match_count + 1
End If
Dim list_num As Integer
list_num = match_count \ 3
If list_num > UBound(list_row, 1) Then
ReDim Preserve list_row(list_num)
list_row(list_num) = 2
End If
ws2.Cells(list_row(list_num), 1 + list_multiplier * list_num).Value = ws1.Range("A" & rw).Value
ws2.Cells(list_row(list_num), 2 + list_multiplier * list_num).Value = ws1.Range("B" & rw).Value
ws2.Cells(list_row(list_num), 3 + list_multiplier * list_num).Value = ws1.Range("C" & rw).Value
ws2.Cells(list_row(list_num), 4 + list_multiplier * list_num).Value = ws1.Range("D" & rw).Value
ws2.Cells(list_row(list_num), 5 + list_multiplier * list_num).Value = ws1.Range("E" & rw).Value
list_row(list_num) = list_row(list_num) + 1
Next rw
End Sub
When you record your macro, ensure that "Use Relative References" on the Developer Ribbon tab is enabled, :)
assuming row 3 has your data headers, you could try this:
Option Explicit
Sub main()
Dim nLists As Long, iList As Long
Dim data As Variant
Dim dataToDelete As Range
With Range("F3", Cells(Rows.Count, 1).End(xlUp))
data = .Value
nLists = WorksheetFunction.Max(.Resize(,1))
nLists = nLists \ 3 + IIf(nLists - 3 * (nLists \ 3) = 0, -1, 0)
End With
With Range("A3").Resize(, 6)
For iList = 0 To nLists
Set dataToDelete = Nothing
With .Offset(, iList * 6).Resize(UBound(data))
.Value = data
.AutoFilter Field:=1, Criteria1:="<=" & iList * 3, Criteria2:=">" & (iList + 1) * 3, Operator:=xlOr
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Set dataToDelete = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
.Parent.AutoFilterMode = False
If Not dataToDelete Is Nothing Then dataToDelete.Delete xlShiftUp
End With
Next
End With
End Sub
Your task is actually slightly trickier than your online advice suggests. Basically, you have to do the following:
Find out how many unique 'keys' (ie unique items in column B) you have. This will tell you the total number of rows you need (ie number of unique keys * 3)
Count the number of items for each 'key'. This will tell you how many columns you need (ie max item count / 3 * number of columns in array [A:E = 5])
Loop through each line of data and it put on appropriate row for that 'key'. Once three has been reached, jump the column for that key 6 columns to the right, and continue.
If you were to use a Class object and Collection type of object, this could be really quite concise code, but judging by your post you are at the beginning of your programming journey in VBA. Therefore, I've broken down each task into separate chunks of code so you will hopefully see how arrays can work for you. Once you practise with arrays a little, perhaps you could have a go at making this code more efficient by combining some of the loops:
Public Sub RunMe()
Dim data As Variant
Dim r As Long, c As Long, i As Long, dataRows As Long, dataCols As Long, keyLen As Long, maxCount As Long
Dim keys As String
Dim k As Variant
Dim keyArray() As String
Dim keyCount() As Long, threeCount() As Long, rowNum() As Long, colNum() As Long
Dim output() As Variant
'Read the data - change "Sheet1" to your sheet name.
'Shows how to write range values into a variant to
'create an array of variants.
data = ThisWorkbook.Worksheets("Sheet1").UsedRange.Value2
dataRows = UBound(data, 1)
dataCols = UBound(data, 2)
'Create a list of unique keys.
'Note: not the most efficient way, but shows how to
'create an array from a value-separated string.
For r = 1 To dataRows
If InStr(keys, CStr(data(r, 2))) = 0 Then
If Len(keys) > 0 Then keys = keys & "|"
keys = keys & CStr(data(r, 2))
End If
Next
keyArray = Split(keys, "|")
keyLen = UBound(keyArray)
'Initialise the row and column numbers for each key.
'Shows how to iterate an array using For Each loop.
ReDim rowNum(keyLen)
ReDim colNum(keyLen)
r = 1
i = 0
For Each k In keyArray
rowNum(i) = r
colNum(i) = 1
r = r + 3
i = i + 1
Next
'Count the number of items for each key.
'Shows how to iterate an array using For [index] loop.
ReDim keyCount(keyLen)
For r = 1 To dataRows
i = IndexOfKey(keyArray, CStr(data(r, 2)))
keyCount(i) = keyCount(i) + 1
If keyCount(i) > maxCount Then maxCount = keyCount(i)
Next
'Size the output array.
c = WorksheetFunction.Ceiling(maxCount / 3, 1)
ReDim output(1 To (keyLen + 1) * 3, 1 To c * dataCols + c - 1)
'Populate the output array.
ReDim threeCount(keyLen)
For r = 1 To dataRows
i = IndexOfKey(keyArray, CStr(data(r, 2)))
'Copy the columns for this row.
For c = 1 To dataCols
output(rowNum(i), colNum(i) + c - 1) = data(r, c)
Next
'Increment the count and if it's equals 3 then
'reset the row num and increase the column number.
threeCount(i) = threeCount(i) + 1
rowNum(i) = rowNum(i) + 1
If threeCount(i) = 3 Then
rowNum(i) = rowNum(i) - 3
colNum(i) = colNum(i) + dataCols + 1
threeCount(i) = 0
End If
Next
'Write the data - change "Sheet2" to your sheet name.
'Shows how to write an array to a Range.
ThisWorkbook.Worksheets("Sheet2").Range("A3") _
.Resize(UBound(output, 1), UBound(output, 2)).Value = output
End Sub
Private Function IndexOfKey(list() As String, key As String) As Long
Dim i As Long
Dim k As Variant
'Helper function to find index position of key in array.
For Each k In list
If key = k Then
IndexOfKey = i
Exit Function
End If
i = i + 1
Next
IndexOfKey = -1
End Function

Resources