# Store subranges from contiguous range into array based on criteria [closed]

My code parses through a contiguous range of data in a spreadsheet (orng) and creates subranges from orng that contain the same string value (lot number) in the 6th column of orng. orng has 42 rows and 38 columns and each subrange has 1-15 rows and 38 columns.

As far as I know, I can't create a new range object for each subrange since the number of subranges is unknown. I've created an array that contains the data for the subranges (aData). I

have gotten it to work with the code below, but I feel like there is a much cleaner way of doing it that I can't figure out. I've also tried using a dictionary with no success. I will eventually have to call upon all the data for calculations and using multiple nested for loops to access each element seems convoluted.

I would prefer that the array was dynamic, but whenever I attempted the ReDim Preserve method the values would not be saved to the array. The size of the array would be correct, but every element was "Empty". According to Microsoft "each element of an array must have its value assigned individually" so it seems as though the only way I can keep the values when creating the array is to assign to each element.

After I found that webpage I implemented an array with a predetermined structure and the nested for loops. Is it possible to add the entire subrange to the array in one go? If not, what about a row?

Ideally, I could separate orng into different Areas, but since it is contiguous I am unable to do so (I'm not aware of a way to create Areas in a contiguous range).

What I'd like to know are:

1. is there a better way to do what I am trying to do (collection, dictionary, etc.)

2. if there is not a better way, can I get some advice on how to make this code cleaner (Easier to read, faster, less code, dynamic range, better structure)?

    Private Sub rangetest()

Dim twb As Workbook: Set twb = ThisWorkbook
Dim cws As Worksheet: Set cws = twb.Sheets("Cleaned_2019+")
Dim orng As Range
Dim datelot As String, datelotcomp As String
Dim c As Long, i As Long, j As Long, k As Long, numrows As Long, lastrow
As Long, numlots As Long, _
curRow As Long, lotRows As Long, startRow As Long, layerRows As Long,
aRow As Long
Dim aLot() As Variant, aData(9, 49, 37) As Variant
Dim Z As Boolean

Set orng = cws.Range("A973:AL1014")   'Set initial range to work with.
numrows = orng.Rows.Count             'Number of rows in orng.
curRow = 1                            'Current row in orng.
startRow = 1                          'Starting row in orng for next
layer (changes when lot changes).
i = 0                                 'Layer of array (for aLot and aData arrays).
j = 0                                 'Row in orng where values for previous layer ended.
Z = False
Do Until Z = True
datelot = Left(orng.Cells(curRow, 6).Value, 10)                            'Lot that we want the data for. Corresponds to a layer in the aData array.
datelotcomp = Left(orng.Cells(curRow + 1, 6).Value, 10)                    'Lot of the next row in data sheet.
If datelot <> datelotcomp Then                                             'If datelotcomp <> to datelot then we want a new layer for array.
layerRows = curRow - j                                                 'Number of rows for a particular layer
ReDim Preserve aLot(i)                                                 'Array of lot names
aLot(i) = datelot                                                      'Assign lot name to aLot array
For aRow = 1 To layerRows                                              'Row index in array
For lotRows = startRow To curRow                                   'Loops through orng rows and sets those values in array
For c = 1 To 38                                                'Loops through columns. There are always 38 columns
aData(i, aRow - 1, c - 1) = orng.Cells(lotRows, c).Value   'Add values to each index in array
Next c
Next lotRows
Next aRow
j = curRow
i = i + 1
startRow = curRow + 1
End If
If curRow = numrows Then                                                   'End loop at end of orng
Z = True
End If
curRow = curRow + 1
Loop
numlots = i

End Sub


The result I get is an array with the structure aData(9, 49, 37) that contains data in the first 4 layers aData(1-3, , ). This corresponds with the unique number of lots (criteria from column 6 of orng) so the code is working correctly. I'd just like advice on if I'm doing anything inefficiently.

I will be checking back to answer questions or to add clarification.

Edit 1:

The orng size will change based on user input. I have the user inputting a start and end date and orng is created based on those values. Once I have the subranges from orng I will then use other criteria from other columns of the subrange to determine which rows to apply calculations to. The end result will be the lot number(s) with the calculations for the lot(s) printed out for the user.

• Ever thought of using a pivot table to do this work for you? – AJD Jul 10 '19 at 22:17
• Yes, there is a better way, and yes you can make the code cleaner. Are you able to post up some sample data and expected output as well? – AJD Jul 10 '19 at 22:19
• A pivot table will not work with what I am going to be doing with the ranges for the end result. Do I just post a picture of the data? I tried adding the data to the original post, but the formatting was a mess. Thank you for your response! – lifeuhfindsaway Jul 11 '19 at 15:09
• If the image is readable on this site, then posting an image should suffice. – AJD Jul 11 '19 at 22:52

There is not much to review as far as the code goes other than avoid using 3D arrays. The problem with 3D arrays is that you need to know the exact size of the first 3 dimensions because only the last dimension is resizable

I attempted the ReDim Preserve method the values would not be saved to the array.

You may want to post your attempts to use ReDim Preserve on StackOverflow because ReDim Preserve does save the values in the array.

Ideally, I could separate orng into different Areas, but since it is contiguous I am unable to do so (I'm not aware of a way to create Areas in a contiguous range). What I'd like to know is 1) is there a better way to do what I am trying to do (collection, dictionary, etc.) and 2) if there is not a better way, can I get some advice on how to make this code cleaner (Easier to read, faster, less code, dynamic range, better structure)?

It is hard to give advice without knowing what you are trying to do with the data other than group it. What I can do is show you how to store non-contiguous ranges in a Dictionary by Lot number and then work with the ranges afterwards.

Private Sub Dictionarytest()
Dim map As New Scripting.Dictionary, rw As Range
Dim key As Variant
'Join Ranges Based on Lot Number and Add them to the Dictionary Map

With ThisWorkbook.Sheets("Cleaned_2019+")
For Each rw In .Range("A973:AL1014").Rows
key = rw.Columns(6).Value

If map.Exists(key) Then
Set map(key) = Union(map(key), rw)
Else
End If
Next
End With

Dim subRange As Range

'Iterate of the Dictionary Map Keys and Print the Join Ranges Addresses
For Each key In map
Set subRange = map(key)
Next

Dim item As Variant
'Iterate of the Dictionary Map Items and Print the Join Ranges Addresses
For Each item In map.Items()
Next

Dim Data As Variant
'Create an Array From the Dictionary Items
Data = map.Items()
'Iterate of the Data Array and Print the Join Ranges Addresses
For Each item In Data
Next

Dim results As Variant
Dim r As Long, c As Long, rowCount As Long
'Iterate of the Dictionary Map Keys and Create Array From the Join Ranges Addresses
'Note: the Results Array Contains all the Data for a Single Lot Number
For Each key In map
Set subRange = map(key)
rowCount = subRange.Cells.CountLarge / subRange.Columns.Count
ReDim results(1 To rowCount, 1 To subRange.Columns.Count)
r = 0
For Each rw In subRange.Rows
r = r + 1
For c = 1 To UBound(results, 2)
results(r, c) = rw.Columns(c).Value
Next
Next
Next

End Sub


Immediate Window Print Out

A973:AL973,A975:AL975,A979:AL979,A985:AL985,A989:AL989,A1006:AL1006 A974:AL974,A982:AL982,A991:AL991,A1002:AL1002,A1013:AL1013 A976:AL976,A1007:AL1007 A977:AL977,A981:AL981,A1001:AL1001 A978:AL978,A988:AL988,A994:AL994,A996:AL996,A1014:AL1014 A980:AL980,A984:AL984,A990:AL990,A998:AL998,A1004:AL1004,A1009:AL1009 A983:AL983,A986:AL986,A993:AL993,A997:AL997,A999:AL999,A1003:AL1003 A987:AL987,A992:AL992,A995:AL995 A1000:AL1000,A1005:AL1005,A1008:AL1008,A1010:AL1011 A1012:AL1012

• as usual (from you) Brilliant use of union with dictionary. I am only started thinking about avoiding use of 3D array. Forcing me to be hardened fan of your code. – Ahmed AU Jul 11 '19 at 1:43
• @AhmedAU thank you sir! – TinMan Jul 11 '19 at 12:41
• I will work on implementing this today and get back to you with the results. This definitely looks more like what I was trying to do, but lacked the know-how. Thank you! – lifeuhfindsaway Jul 11 '19 at 15:13
• This was the core code I ended up using. I had to add some qualifiers, but it worked as intended in the end. Thank you very much. – lifeuhfindsaway Jul 16 '19 at 22:50
• @lifeuhfindsaway I'm glad that it helped. Thanks for accepting my answer. – TinMan Jul 17 '19 at 8:58