The function below finds the first result.
There could be duplicate rows with matching values that meet my if statements. How would I create an array to store the row numbers the search function found so that I can process the data later.
How would I create the array size based on the number of results found in the for loop?
I am assuming that the for loop counter will have some sort of role to play in this. Let's say the for loop found 2 matches in row numbers 56 and 98 matching my if statements:
array_example(counter, 0) = 56
array_example(counter, 0) = 98
The stored values would be:
array_example(1, 0) = 56
array_example(2, 0) = 98
Private Sub Complex_Search(col1, cval1, col2, cval2)
'MsgBox (col1 & " " & col2)
'MsgBox (cval1 & " " & cval2)
Dim i
Dim lRow
Dim Counter
lRow = Cells(Rows.Count, 1).End(xlUp).row
Counter = 0
With Sheets("Office Spaces")
For i = 2 To lRow
If LCase(.Cells(i, col1).Value) = LCase(cval1) And LCase(.Cells(i, col2).Value) = LCase(cval2) Then
row = i
Counter = Counter + 1
End If
Next i
End With
If row = "" Then
MsgBox ("Search complete. 0 results found")
Else
GetRowData (row)
UserForm1.resmax.Value = 1
End If
End Sub
It's worth noting that you haven't even initialized row, and have just let vba implicitly declare it as a variant type for you. To avoid common problems that arise from typos, include Option Explicit at the top of your code and Dim every variable with the type beside it. For example: Dim i as long. Dim i will work, but it will declare it as a variant type
To initialize an array in VBA you use Dim row() as variant. From there you can re-dimension its size using Redim row(LboundX to UboundX) but this will reset all the stored values to zero. To get around this use Redim Preserve row(LBoundX to UBound X).
If you wish to use a 2D array, add a comma and then put the bounds for the next dimension Redim Preserve row(LBoundX to UBound X, LboundY to UBoundY)
At the top of your code I would include
Dim row() as Variant
Redim Preserve row(1 to 1)
Then within the loop I would change row = i to
row(Ubound(row)) = i
Redim Preserve row(1 to Ubound(row) +1)
Now that you have an array though, the check you do below will no longer work and will likely throw an error because you there's no specified index. Instead I suggest changing it from If row = "" Then to If Counter = 0 Then.
I'm not sure what the intention is with GetRowData(row) but you can just access each row number via row(i). It is worth noting however, that the row array will have Counter +1 number of items, but the last one will be blank. You could get around this by adding in an if statement within the already existing one that would look something like this:
If Counter = 0 Then
row(1) = i
Else
ReDim Preserve row(1 To UBound(row) + 1)
row(UBound(row)) = i
End If
Counter = Counter + 1
By implementing this change, row should have exactly Counter number of items that all have a non-empty value
I don't really suggest making a column array because it becomes more cumbersome to change the array size. Redim preserve or not only allows you to change the last dimension in the array, so to change the number of rows you would have to set the array equal to the transpose of itself, do the redim and then set it to the transpose of itself again. It's just needlessly messy. If you're pasting it to a sheet and need it to be in a column you could just transpose it at the end instead.
Related
I am trying to put in place a macro that allows me to match identical entry from one table to another. The tricky part is that if a match is found, it cannot be repeated. The way I theorized it is kind of elementary, however it is the only way I can think of it given my still limited knowledge in VBA.
The structure
Both tables need to be first filtered in order to allow the non-repetition condition.
Store the searching values as arrays in order to speed up the process of the macro
Match the entries to search with the ones from the targeted table in order to find matches. This is done with the in-application function MATCH. The MATCH function returns the cell where the match is situated, this is useful as it constantly shift the range in order to not repeate the same value all the time.
After calculating the shifting range, I use a VLookup function in order to return the second entry.
Unfortunately, the macro is incomplete. I cannot find a way to constantly shift the range without compromising the mechanism. The problem resides in the shifting range that is not created correctly to shift after each match.
Desired result
In the below image the desired result would be to check if all items in the left table are in the right table. Take item A, I need to find two item As. I have in the right column a first item A with value 17 and a second item A with value 81. If I do not find any value I have nothing, as it is the case of Ds and E. If instead I have less entries in the left table (as it is for the case of entry L) then I need to return all values of Entry L: 96; 77; 40.
Sub Matching11()
ThisWorkbook.Activate
Worksheets.add
Worksheets("Test4").Range("A1:T110").copy Destination:=ActiveSheet.Range("A1")
With ActiveSheet
Dim Search_Array As Variant
Search_Array = Range("C2", Range("C1").End(xlDown)) 'use this array to loop through the value to search for
Dim Target_MatchValue As Integer
Dim Target_Range As Range
Dim arr As Variant
Dim counter As Integer
Dim n As Integer
counter = 0
n = 0
Target_MatchValue = 0
For counter = LBound(Search_Array) To UBound(Search_Array)
Target_MatchValue = 0
Target_MatchValue = Application.Match(Search_Array(counter, 1), .Range("H2:H200"), 0) - 1 'change C column with the range where you will have the tyres you need search for
Set Target_Range = .Range(.Cells(2 + n, 8), .Cells(1000, 9)) 'this is supposed to work as a shifting range allowing to match entries without making repetitions. I used the MATCH function in order to set the start of the range. i.e. if there is a match in the target table the range will shift from the location of the match downwards. If the match is at on the same level then it does not shift the range in order to match the same-level entry afterwards it is supposed to shift by one unit in order to prevent repetitions.
'If arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False) Is Nothing Then GoTo NextCounter 'I used Vlookup in order to return the value set in the second column of the targetted table. As alternative, I think I could just use offset since I previously used MQTCH
arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False)
If IsError(arr) Then
GoTo NextCounter
Else
.Range(Cells(1 + counter, 6), Cells(1 + counter, 6)).value = arr 'Return the value of the array in this cell
End If
Target_Range.Select
If Target_MatchValue = 0 Then
n = n + 1
ElseIf Target_MatchValue > 0 Then
n = n + Target_MatchValue
End If
.Range(Cells(1 + counter, 5), Cells(1 + counter, 5)).value = Search_Array(counter, 1) 'Return the value of the array in this cell
Next counter
NextCounter:
Next counter
End With
End Sub
Well, Let's see if this helps you out and probably you can adapt it to your needs.
I replied your data like this:
The macro will create a list in columns H:I like the right table of your image. The macro will always delete any previous result. My macro works on standard ranges, is not designed to work on tables (ListObjects in VBA), but you can easily adapt it to your needs.
Sub CREATE_LIST()
Application.ScreenUpdating = False
Dim LastRow As Long
Dim MyRange As Range
Dim rng As Range
Dim i As Long
'we clear previous list
Columns("H:I").Delete
'we add data
Range("H1").Value = "Target"
Range("I1").Value = "Return"
LastRow = Range("C" & Rows.Count).End(xlUp).Row 'Last row of column C, where data is.
Set MyRange = Range("D2:D" & LastRow).SpecialCells(xlCellTypeConstants, 23) 'we select only NON BLANK cells
i = 2 'initial row
For Each rng In MyRange
Range("H" & i).Value = rng.Offset(0, -1).Value 'value of adjacent cell (Column C)
Range("I" & i).Value = rng.Value 'value of cell in column D
i = i + 1
Next rng
Application.ScreenUpdating = True
End Sub
After executing code I get:
And trying different data works too:
Hope you can adapt this to your needs.
Apologies for the unclear explanation of the problem. I have provided here below a solution I have sorted out. I was looking for a code that could execute vlookup without returning the same values. Below is the solution. I am aware that the code might not be the cleanest and most elegant one but it is effective and run fast enough for large data sample.
Sub Matching()
Dim Search_Array As Variant
Dim Target_MatchValue As Variant
Dim Target_Range As Range
Dim arr As Variant
Dim counter As Integer
Dim n As Integer
'data must be ordered in order to apply the non-repetitive condition
Search_Array = Sheet1.Range("A2", Sheet1.Range("A1").End(xlDown)) 'use this array to loop through the value to search for
n = 0
Sheet1.Activate
With ActiveSheet
For counter = LBound(Search_Array) To UBound(Search_Array)
Target_MatchValue = 0
Target_MatchValue = Application.Match(Search_Array(counter, 1), .Range(Cells(2 + n, 4), Cells(1000, 4)), 0) 'This code will return the value used for the shifting range
Set Target_Range = .Range(Cells(2 + n, 4), Cells(1000, 5)) 'this is supposed to work as a shifting range allowing to match entries without making repetitions. I used the MATCH function in order to set the start of the range. i.e. if there is a match in the target table the range will shift from the location of the match downwards. If the match is at on the same level then it does not shift the range in order to match the same-level entry afterwards it is supposed to shift by one unit in order to prevent repetitions.
'target_range.select Activate this code in order to see the macro in action
arr = Application.VLookup(Search_Array(counter, 1), Target_Range, 2, False) 'store the vlookup value in an array in order to increase the efficiency the code and to speed up the whole proces
If IsError(arr) Then
.Cells(2 + n, 2).value = "" 'if the macro does not find anything, no value will be recorded anywhere
Else
.Cells(1 + n + Target_MatchValue, 2).value = Search_Array(counter, 2) 'Return the value of the search_array in this cell so to match column A values with column D values if they are found
End If
If IsError(arr) Then
n = n
ElseIf Target_MatchValue = 0 Then 'if the macro does not find anything, the shifting range does not shift so that subsequent values can be searched in the same range without missing precious matches
n = n + 1
ElseIf Target_MatchValue > 0 Then 'if there is a matching value between Column A and Column B, the shifting range shifts by the n + the distance between the the current vlookupvalue and the found value. Note that Data must be stored in a filtered order otherwise vlookup will not work correctly
n = n + Target_MatchValue
End If
Next counter
End With
End Sub
By exchanging ideas with some friends, I was told to think about a potential helper column that would be used to store incremental numbers. This helper column would store incremental numbers that would help to meet the non-repetition condition. Please see the below example.
The idea here is that if a value is found in column E, I store n being equal to the value found in the helper column. Then the code needs to verify if the future values' n are bigger than previous n. If this condition is met, then the one-repetition condition is fulfilled. n changes value to the next bigger value.
For example, if I find L in the right table, I report 96 as value and store N being equal to 11. When I search for the next value of L, the new n must be bigger than the current n otherwise I will not store the new found value. The value 77 found has indeed a bigger n than the previous value as 12 is bigger than 11. I hope this helps.
I'm trying to populate a combo box with UNIQUE values only, no duplicates; which I believe is working fine, but something is wrong with my logic in the second For loop
The below logic goings as follows...
Private Function PopulateComboBoxWeeks()
Dim i As Long
Dim x As Long
Dim LR As Long
Dim ws As Worksheet
Dim SearchNextWeek As String
LR = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set ws = ActiveSheet
With UserForm1.ComboBox1
''' Fill first slot in ComboBox1 with the value of last row in Column "A"
.AddItem ws.Range("A" & LR).Value
''' Loop to search Column "A" for items to fill with, start on the second last row, since the above line fills the first line
For i = LR - 1 To 2 Step -1
''' Loop to search the ComboBox.List() array
For x = 0 To .ListCount
''' Array list starts at 0
If Not (.List(x) = ws.Range("A" & i).Value) Then
.AddItem ws.Range("A" & i).Value
End If
Next x
Next i
End With
End Function
It's checking the Array list properly, but I'm stuck on the second For loop, if I start at index 0 of my array and it's taking into account the total items in the array with .ListCount. Thus it's giving me the below error...
Run-Time error '381':
Could not get the List property. Invalid property array index
Which could only mean I'm referencing an array item outside of the array size. I've tried doing .ListCount - 1 but this gives me an infinite loop. I think all my logic is sound here except this one item and I'm not sure how to get passed this point.
Iterating any collection as you're changing it is always a bad idea.
Don't loop on anything. Just tell it what range you want to use.
If you can't do that, then you need to first get the unique values into an array (single-dimensional), then assign ComboBox1.List = theArray. Done.
There are two things you want to do:
Figure out what the unique values are
Assign the List property
Don't do these two things in one single nested spaghetti loop. Separate them.
Dim allValues As Variant
'get a single-dimensional array with all the values in the column:
allValues = Application.WorksheetFunction.Transpose(ws.Range("A2:A" & LR).Value)
'let's use built-in collection keys to ensure uniqueness:
Dim uniqueValuesColl As Collection
Set uniqueValuesColl = New Collection
Dim currentIndex As Long
For currentIndex = LBound(allValues) To UBound(allValues)
If Not IsError(allValues(currentIndex)) Then
On Error Resume Next
uniqueValuesColl.Add allValues(currentIndex), Key:=CStr(allValues(currentIndex))
If Err.Number <> 0 Then
' we already have that value
Err.Clear
End If
On Error GoTo 0
End If
Next
'now we know what the unique values are - get them into an array:
ReDim uniqueValues(0 To uniqueValuesColl.Count - 1)
Dim currentItem As Variant
currentIndex = 0
For Each currentItem In uniqueValuesColl
uniqueValues(currentIndex) = currentItem
currentIndex = currentIndex + 1
Next
'just assign the list of unique values
ComboBox1.List = uniqueValues
So I'm iterating all values once, and then the unique values once. But you're currently iterating them once for every single item in the non-unique list. So this solution is O(n+m) where n is the number of non-unique items and m is the number of unique items, whereas your nested loop is O(n2) (the big-O notation of your solution is actually more complicated than that, but I'm no big-O expert).
Problem: I am comparing two columns of names. If a name from the primary column matches a name in the secondary column, then I would like to add the matching name to an array of strings.
Function 1: This boolean function should indicate whether there is a match:
Function Match(name As String, s As Worksheet, column As Integer) As Boolean
Dim i As Integer
i = 2
While s.Cells(i, column) <> ""
If s.Cells(i, column).Value = name Then
Match = True
End If
i = i + 1
Wend
Match = False
End Function
Function 2: This function should add the matching name to a dynamic array of strings. Here I am somewhat stuck as I am new to arrays- any suggestions?
Function AddToArray(ys) As String()
Dim a() As String
Dim size As Integer
Dim i As Integer
Dim sh As Worksheet
Dim rw As Range
size = 0
ReDim Preserve a(size)
For Each rw In sh.Rows
If Match(sh.Cells(rw.Row, 1), s, column) = True Then
??
size = size + 1
End Function
Here is one solution. I scrapped your Match function and replaced it with a Find function.
Option Explicit
Sub AddToArray()
Dim primaryColumn As Range, secondaryColumn As Range, matchedRange As Range
Dim i As Long, currentIndex As Long
Dim matchingNames As Variant
With ThisWorkbook.Worksheets("Sheet1")
Set primaryColumn = .Range("A1:A10")
Set secondaryColumn = .Range("B1:B10")
End With
'Size your array so no dynamic resizing is necessary
ReDim matchingNames(1 To primaryColumn.Rows.Count)
currentIndex = 1
'loop through your primary column
'add any values that match to the matchingNames array
For i = 1 To primaryColumn.Rows.Count
On Error Resume Next
Set matchedRange = secondaryColumn.Find(primaryColumn.Cells(i, 1).Value)
On Error GoTo 0
If Not matchedRange Is Nothing Then
matchingNames(currentIndex) = matchedRange.Value
currentIndex = currentIndex + 1
End If
Next i
'remove unused part of array
ReDim Preserve matchingNames(1 To currentIndex - 1)
'matchingNames array now contains just the values you want... use it how you need!
Debug.Print matchingNames(1)
Debug.Print matchingNames(2)
'...etc
End Sub
Extra comments
There is no need to create your own Match function because it already exists in VBA:
Application.Match()
WorksheetFunction.Match()
and as I mentioned above you can also achieve the same result with the Find function which is my preference here because I prefer the way you can check for no matches (other methods throw less convenient errors).
Finally, I also opted to restructure your code into one Sub rather than two Functions. You weren't returning anything with your AddToArray function which pretty much means by definition it should actually be a Sub
As I stated in a comment to the question, there are a couple of problems in your code before adding anything to the array that will prevent this from working, but assuming that this was caused by simplifying the code to ask the question, the following should work.
The specific question that you are asking, is how to populate the array while increasing its size when needed.
To do this, simply do this:
Instead of:
ReDim Preserve a(size)
For Each rw In sh.Rows
If Match(sh.Cells(rw.Row, 1), s, column) = True Then
Reorder this so that it is:
For Each rw In sh.Rows
If Match(sh.Cells(rw.Row, 1), s, column) = True Then
ReDim Preserve a(size) 'increase size of array
a(size) = sh.Cells(rw.Row,1) 'put value in array
size = size + 1 'create value for size of next array
End If
Next rw
....
This probably isn't the best way to accomplish this task, but this is what you were asking to do. First, increasing the array size EVERY time is going to waste a lot of time. It would be better to increase the array size every 10 or 100 matches instead of every time. I will leave this exercise to you. Then you could resize it at the end to the exact size you want.
I'm having a seemingly basic problem but can't find any resources addressing it.
Simply put, I just want to load the contents of a Range of cells (all one column) into an Array.
I am able to accomplish this by means of
DirArray = Array(Range("A1"), Range("A2"))
But for some reason, I cannot create the array when expressed this way:
DirArray = Array(Range("A1:A2"))
My real Range is much longer (and may vary in length), so I don't want to have to individually enumerate the cells this way. Can anyone tell me how to properly load a whole Range into an Array?
With the latter code:
MsgBox UBound(DirArray, 1)
And
MsgBox UBound(DirArray)
Return 0, whereas with the former they return 1.
Just define the variable as a variant, and make them equal:
Dim DirArray As Variant
DirArray = Range("a1:a5").Value
No need for the Array command.
If we do it just like this:
Dim myArr as Variant
myArr = Range("A1:A10")
the new array will be with two dimensions. Which is not always somehow comfortable to work with:
To get away of the two dimensions, when getting a single column to array, we may use the built-in Excel function “Transpose”. With it, the data becomes in one dimension:
If we have the data in a row, a single transpose will not do the job. We need to use the Transpose function twice:
Note: As you see from the screenshots, when generated this way, arrays start with 1, not with 0. Just be a bit careful.
Edit June.2021:
In newer versions of Excel, the function is: Application.WorksheetFunction.Transpose()
Using Value2 gives a performance benefit. As per Charles Williams blog
Range.Value2 works the same way as Range.Value, except that it does not check the cell format and convert to Date or Currency. And thats probably why its faster than .Value when retrieving numbers.
So
DirArray = [a1:a5].Value2
Bonus Reading
Range.Value: Returns or sets a Variant value that represents the value of the specified range.
Range.Value2: The only difference between this property and the Value property is that the Value2 property doesn't use the Currency and Date data types.
This function returns an array regardless of the size of the range.
Ranges will return an array unless the range is only 1 cell and then it returns a single value instead. This function will turn the single value into an array (1 based, the same as the array's returned by ranges)
This answer improves on previous answers as it will return an array from a range no matter what the size. It is also more efficient that other answers as it will return the array generated by the range if possible. Works with single dimension and multi-dimensional arrays
The function works by trying to find the upper bounds of the array. If that fails then it must be a single value so we'll create an array and assign the value to it.
Public Function RangeToArray(inputRange As Range) As Variant()
Dim size As Integer
Dim inputValue As Variant, outputArray() As Variant
' inputValue will either be an variant array for ranges with more than 1 cell
' or a single variant value for range will only 1 cell
inputValue = inputRange
On Error Resume Next
size = UBound(inputValue)
If Err.Number = 0 Then
RangeToArray = inputValue
Else
On Error GoTo 0
ReDim outputArray(1 To 1, 1 to 1)
outputArray(1,1) = inputValue
RangeToArray = outputArray
End If
On Error GoTo 0
End Function
In addition to solutions proposed, and in case you have a 1D range to 1D array, i prefer to process it through a function like below. The reason is simple: If for any reason your range is reduced to 1 element range, as far as i know the command Range().Value will not return a variant array but just a variant and you will not be able to assign a variant variable to a variant array (previously declared).
I had to convert a variable size range to a double array, and when the range was of 1 cell size, i was not able to use a construct like range().value so i proceed with a function like below.
Public Function Rng2Array(inputRange As Range) As Double()
Dim out() As Double
ReDim out(inputRange.Columns.Count - 1)
Dim cell As Range
Dim i As Long
For i = 0 To inputRange.Columns.Count - 1
out(i) = inputRange(1, i + 1) 'loop over a range "row"
Next
Rng2Array = out
End Function
I'm another vote for iterating through the cells in the range. Unless somebody has found a workaround, my experience trying to assign the range directly to a Variant has been that it works fine (albeit returning a 2-dimensional array when I really only need 1D) except if my range has multiple areas, like for example, when I want just the visible cells in a column of a filtered table, or if I have ctrl-selected different blocks of cells on a sheet.
Iterating through all the cells in the range with a for..each loop always produces the results I expect.
Public Function RangeToArray(ByRef myRange As Range)
Dim i As Long
Dim individualCell As Range
ReDim myArray(myRange.Count - 1)
For Each individualCell In myRange
myArray(i) = individualCell.Text ' or maybe .Value
i = i + 1
Next
RangeToArray = myArray
End Function
I wanted to add this as a comment to Paolo's answer since it's pretty similar but I am a newbie and don't have enough reputation, so here's another slightly different answer.
Adding to #Vityata 's answer, below is the function I use to convert a row / column vector in a 1D array:
Function convertVecToArr(ByVal rng As Range) As Variant
'convert two dimension array into a one dimension array
Dim arr() As Variant, slicedArr() As Variant
arr = rng.value 'arr = rng works too (https://bettersolutions.com/excel/cells-ranges/vba-working-with-arrays.htm)
If UBound(arr, 1) > UBound(arr, 2) Then
slicedArr = Application.WorksheetFunction.Transpose(arr)
Else
slicedArr = Application.WorksheetFunction.index(arr, 1, 0) 'If you set row_num or column_num to 0 (zero), Index returns the array of values for the entire column or row, respectively._
'To use values returned as an array, enter the Index function as an array formula in a horizontal range of cells for a row,_
'and in a vertical range of cells for a column.
'https://usefulgyaan.wordpress.com/2013/06/12/vba-trick-of-the-week-slicing-an-array-without-loop-application-index/
End If
convertVecToArr = slicedArr
End Function
Transpose is a great advice.
I have multiple arrays in my app. Some global, some local, some loaded from ranges and some created programatically.
I had numerous problems with dimensioning. Now, with transpose they are all one dimension.
I did have to modify code slightly, because one version runs on Excel 2003 and another (slower) on 2010.
Caution: You will have to Transpose the array again, when saving it to a range.
Using the shape of the Range
Another approach in creating a function for ArrayFromRange would be using the shape and size of the Range to determine how we should structure the array. This way we don't have to load the data into an intermediate array to determine the dimension.
For instance, if the target range is only one cell, then we know we want to return an array with the single value in it Array(target.value).
Below is the complete function that should deal with all cases. Note, this uses the same technique of using the Application.Transpose method to reshape the array.
' Helper function that returns an array from a range with the
' correct dimensions. This fixes the issue of single values
' not returning as an array, and when a 2 dimension array is returned
' when it only has 1 dimension of data.
'
' #author Robert Todar <robert#roberttodar.com>
Public Function ArrayFromRange(ByVal target As Range) As Variant
Select Case True
' Single cell
Case target.Cells.Count = 1
ArrayFromRange = Array(target.Value)
' Single Row
Case target.Rows.Count = 1
ArrayFromRange = Application.Transpose( _
Application.Transpose(target.Value) _
)
' Single Column
Case target.Columns.Count = 1
ArrayFromRange = Application.Transpose(target.Value)
' Multi dimension array
Case Else
ArrayFromRange = target.Value
End Select
End Function
Testing the ArrayFromRange function
As a bonus, here are the tests that I ran to check that this function works.
' #requires {function} ArrayDimensionLength
' #requires {function} ArrayCount
Private Sub testArrayFromRange()
' Setup a new workbook/worksheet for
' adding testing data
Dim testWorkbook As Workbook
Set testWorkbook = Workbooks.Add
Dim ws As Worksheet
Set ws = testWorkbook.Worksheets(1)
' Add sample data for testing.
ws.Range("A1:A2") = Application.Transpose(Array("A1", "A2"))
ws.Range("B1:B2") = Application.Transpose(Array("B1", "B2"))
' This section will run all the tests.
Dim x As Variant
' Single cell
x = ArrayFromRange(ws.Range("A1"))
Debug.Assert ArrayDimensionLength(x) = 1
Debug.Assert ArrayCount(x) = 1
' Single Row
x = ArrayFromRange(ws.Range("A1:B1"))
Debug.Assert ArrayDimensionLength(x) = 1
Debug.Assert ArrayCount(x) = 2
' Single Column
x = ArrayFromRange(ws.Range("A1:A2"))
Debug.Assert ArrayDimensionLength(x) = 1
Debug.Assert ArrayCount(x) = 2
' Multi Column
x = ArrayFromRange(ws.Range("A1:B2"))
Debug.Assert ArrayDimensionLength(x) = 2
Debug.Assert ArrayCount(x) = 4
' Cleanup testing environment
testWorkbook.Close False
' Print result
Debug.Print "testArrayFromRange: PASS"
End Sub
Helper functions for the tests
In my tests I used two helper functions: ArrayCount, and ArrayDimensionLength. These are listed below for reference.
' Returns the length of the dimension of an array
'
' #author Robert Todar <robert#roberttodar.com>
Public Function ArrayDimensionLength(sourceArray As Variant) As Integer
On Error GoTo catch
Do
Dim currentDimension As Long
currentDimension = currentDimension + 1
' `test` is used to see when the
' Ubound throws an error. It is unused
' on purpose.
Dim test As Long
test = UBound(sourceArray, currentDimension)
Loop
catch:
' Need to subtract one because the last
' one errored out.
ArrayDimensionLength = currentDimension - 1
End Function
' Get count of elements in an array regardless of
' the option base. This Looks purely at the size
' of the array, not the contents within them such as
' empty elements.
'
' #author Robert Todar <robert#roberttodar.com>
' #requires {function} ArrayDimensionLength
Public Function ArrayCount(ByVal sourceArray As Variant) As Long
Dim dimensions As Long
dimensions = ArrayDimensionLength(sourceArray)
Select Case dimensions
Case 0
ArrayCount = 0
Case 1
ArrayCount = (UBound(sourceArray, 1) - LBound(sourceArray, 1)) + 1
Case Else
' Need to set arrayCount to 1 otherwise the
' loop will keep multiplying by zero for each
' iteration
ArrayCount = 1
Dim dimension As Long
For dimension = 1 To dimensions
ArrayCount = ArrayCount * _
((UBound(sourceArray, dimension) - LBound(sourceArray, dimension)) + 1)
Next
End Select
End Function
I am trying to delete blank entries from an array that was loaded from a field called TY[L3 Name] (1 column, X rows long) from a data table in excel. The below code is intended to remove all blank values from the array (once it has been loaded with the range), and return a new array with rows that only have data in them. I will want to pass this array onto a collection later to remove duplicates, but I am trying to figure out why I can't get ride of the blanks first (now I am at a point where I just want to understand how to do this regardless if i pass this onto something else or not).
The code errors out at the ReDim Preserve line. I first sized the NewArr to the MyArr table, but had blank rows returned at the end. I then tried to resize it so I only had rows with data in them, but I cannot seem to get the NewArr() array to do this without an error.
I am using the immediate window to verify that there are no blank entries (currently 8 rows at the end of the TY[L3 Name] range).
Sub BuildArray()
' Load array
Dim MyArr()
Dim j As Long
' Size array
MyArr() = Range("TY[L3 Number]")
ReDim NewArr(LBound(MyArr) To UBound(MyArr), 1)
' For Loop to search for Blanks and remove from Array
' The Lbound and UBound parameters will be defined by the size of the TY[L3 Number] field in the TY Table
For i = LBound(MyArr) To UBound(MyArr)
If MyArr(i, 1) <> "" Then
j = j + 1
NewArr(j, 1) = MyArr(i, 1)
End If
Next i
ReDim Preserve NewArr(1 To j, 1) 'Error out here; "Subscript out of range." Can't seem to get this Array to new size without blank entries.
' Debug Window to show results of revised array.
Dim c As Long
For c = LBound(NewArr) To UBound(NewArr)
Debug.Print NewArr(c, 1)
Next
Debug.Print "End of List"
End Sub
Working through arrays can be tricky in VBA, but I think the example below will show you how a different strategy for populating the "No Blanks" Array might be work:
Suppose we start off with a single Worksheet, with the CoolRange named as shown:
Generating an array without blanks could be done like this:
Option Explicit
Sub BuildArrayWithoutBlanks()
Dim AryFromRange() As Variant, AryNoBlanks() As Variant
Dim Counter As Long, NoBlankSize As Long
'set references and initialize up-front
ReDim AryNoBlanks(0 To 0)
NoBlankSize = 0
'load the range into array
AryFromRange = ThisWorkbook.Names("CoolRange").RefersToRange
'loop through the array from the range, adding
'to the no-blank array as we go
For Counter = LBound(AryFromRange) To UBound(AryFromRange)
If AryFromRange(Counter, 1) <> "" Then
NoBlankSize = NoBlankSize + 1
AryNoBlanks(UBound(AryNoBlanks)) = AryFromRange(Counter, 1)
ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) + 1)
End If
Next Counter
'remove that pesky empty array field at the end
If UBound(AryNoBlanks) > 0 Then
ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) - 1)
End If
'debug for reference
For Counter = LBound(AryNoBlanks) To UBound(AryNoBlanks)
Debug.Print (AryNoBlanks(Counter))
Next Counter
Debug.Print "End of List"
End Sub
So, to summarize, we:
Create a 1-D array for our eventual array with blanks removed
Iterate through our original array (with blanks)
Unless the array field is blank, we increase our non-blank counter, then add the value to the non-blank array, then expand the non-blank array
Blow away the last pesky empty field in our non-blank array
From your problem description, it sounds like you'll eventually be stripping away duplicates with a Collection -- love it. Out of curiosity, what will you use the non-blank-but-with-duplicates array for?
I have worksheet data to remove the lines with "Templates" in them and copy to a second worksheet. Same idea as removing blank lines. I copied the raw data to INArr. I know the width is 16 (Columns) but the length (Rows) is variable. REDIM PRESERVE only works on the last dimension so I transposed the array so it is now 16 rows and unlimited columns while removing the unwanted data. Transpose the array back and copy to the final work sheet.
Hope that makes sense.
'Copy data from Worksheet3 to INArr, Remove "TEMPLATES" and copy to Worksheet2
LR = Sheet3.Cells(Rows.Count, "A").End(xlUp).Row
INArr = Sheet3.Range("B6:Q" & LR).Value2
ReDim TempArr(1 To 16, 1 To 1)
x = 0
For i = 1 To UBound(INArr)
If INArr(i, 14) <> "TEMPLATES" Then
x = x + 1
ReDim Preserve TempArr(1 To 16, 1 To x)
For j = 1 To 16
TempArr(j, x) = INArr(i, j)
Next
End If
Next
ReDim OutArr(1 To x, 1 To 16)
For i = 1 To x
For j = 1 To 16
OutArr(i, j) = TempArr(j, i)
Next
Next
Sheet2.Range("A3:P" & x + 2).Value2 = OutArr