I have a column of data with unique strings where the first 4 characters in the string may be a repeat of the first 4 characters in another string, in a format similar to:
ABCDEF
ABCDXY
ABCDKL
DTYTZF
DTYTSD
I am attempting to loop through this data to identify which 4 starting characters appear more then three times. If the first 4 digits of the string occur 3 times or more, I would like to remove these from the array entirely, and end up with an array that excludes these values. For example, in my column above, as 3 strings or more begin with 'ABCD', I would like to remove all strings that begin with this code, and have only every other value remain, such that my result would be:
DTYTZF
DTYTSD
I am currently looping through the array, pushing any value that occurs three times or more into a NEW array, and plan to then use that list to do a second pass on the original array, and remove any matches. This may not be the most efficient way, but I've not been able to determine a better way that is guaranteed not to mess my data up.
I have worked through looping through the strings to identify which strings occur more then once, but when I try to push them to an array, the string successfully is pushed to the array, but is then replaced with the next value as soon as it is pushed to the array. I know the value is pushed correctly, because if I view the array immediately afterwards, I see the value in the array. When the next value is pushed and you view the array again, only the new value is displayed (The older ones are not).
I believe this is due to my limited understanding of ReDim-ing arrays, and me not fully understanding a code snippet for pushing this value into an array. My (condensed) code is as follows:
Sub pickupValues()
Dim valuesArray()
Dim i As Long
Dim y As Long
Dim sizeCheck As Long
Dim tempArray() As String
valuesArray() = Worksheets("Sheet1").Range("A1:A10").Value
For i = LBound(valuesArray) To UBound(valuesArray)
sizeCheck = 0
For y = LBound(valuesArray) To UBound(valuesArray)
If Left(valuesArray(i, 1), 4) = Left(valuesArray(y, 1), 4) Then
sizeCheck = sizeCheck + 1
i = y
If sizeCheck >= 3 Then
ReDim tempArray(1 To 1) As String 'I'm not sure why I need to do this.
tempArray(UBound(tempArray)) = Left(valuesArray(i, 1), 4) 'I believe this is what pushes the value into the array.
ReDim Preserve tempArray(1 To UBound(tempArray) + 1) As String 'Again unsure on what the purpose of this is.
viewArray (tempArray)
End If
End If
Next y
Next i
End Sub
Function viewArray(myArray)
Dim txt As String
Dim i As Long
For i = LBound(myArray) To UBound(myArray)
txt = txt + myArray(i) + vbCrLf
Next i
MsgBox txt
End Function
What am I doing wrong?
I would like to re-use the same basic code later in the function to push other values OUT of an array based on if they match the string or not, but it seems VBA does not like to move values out of arrays either. Is there an easy solution that would match both scenarios?
I've rewritten what you are trying to do. I'm using the filter function to quickly get your results in the array
Option Explicit
Public Sub pickupValues()
Dim tmp As Variant
Dim results As Variant
Dim i As Long
Dim v
' Make sure this matches your range
With ThisWorkbook.Sheets("Sheet1")
' Important to transpose the input here as Filter will only take a 1D array. Even though it's only 1 column, setting an array this way will generate a 2D array
tmp = Application.Transpose(.Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)).Value2)
End With
' ReDiming to the maximum value and slimming down afterwards is much quicker then increasing your array each time you've found a new value
ReDim results(1 To UBound(tmp))
For Each v In tmp
' Less then 2 as first result is '0'. Will return '-1' if can't be found but as test criteria is in the array it will always be at least 0
If UBound(Filter(tmp, Left(v, 4))) < 2 Then
i = i + 1
results(i) = v
End If
Next v
' Redim Preserve down to actual array size
If i > 0 Then
ReDim Preserve results(1 To i)
viewArray (results)
Else
MsgBox "Nothing Found"
End If
End Sub
' Should really be a sub as doesn't return anything back to caller
Public Sub viewArray(myArray)
MsgBox Join(myArray, vbCrLf)
End Sub
Your algorithm is not helping you.
Option 1:
Sort your array. Then you can make a single pass to find sequential values with the same first four characters and count them.
Option 2:
Use a Dictionary object: first four characters as key, number of occurrences as value.
Related
This question already has an answer here:
Search for an element in the VBA ArrayList
(1 answer)
Closed 2 years ago.
I was trying to delete the specific element in the array vba when certain condition are true but i end up getting error 424. May I know the right way to do it? I tired to use redim, however it doesn't suit my condition as after the comparing with others array i need to store the data back into excel file where the location in the excel file is already sorted.
Before changing the remarkRange to array variant, I used it as Dim remarkRange
As Range where I can just use .Clear to clear the range item in a specific element.
I tried remarkRange(I, 1)=" " it runs without error but im not sure if its suitable. May I know the correct way to do it? Thanks.
Dim remarkRange() As Variant
remarkRange= wb.Sheets("wb").Range("A1:A5").Value2
For I = LBound(remarkRange) To UBound(remarkRange)
If (some condition is true) then
remarkRange(I, 1).Delete
End If
Next I
I expected the element in the specific cell in the array to be empty, but I got error 424
An array doesn't have a Delete method. It's also misleading to have the Range in remarkRange when it's an array, not a Range. Maybe a different name, e.g. remarks or whatever is clear to you.
If you're going to write the array back to the worksheet, then I see no problem changing an element to a blank string.
For i = LBound(remarks, 1) To UBound(remarks, 1)
If some condition Then
remarks(i, 1) = ""
End If
Next i
It seems you'll need to decide what you mean by 'delete'. I'm not aware of a Delete property of an array of variants so while your code might compile it would throw an object required error.
However, your point about previously using the Clear method on a Range object, suggests that you just want to read your range values into an array, remove the contents if certain conditions aren't me, and then re-write your array to the range. If that's the case, you probably wouldn't want to resize your array as the rows or columns wouldn't line up - more commonly, you'd set the item of your variant array to Empty.
The code below shows how to do this in a simple routine of taking 10 numbers from column A, removing all odd numbers and re-writing the numbers to Column C - but with the rows still matching:
Public Sub EmptyItemsAndKeepArraySize()
Dim inArr() As Variant
Dim i As Long
'Read range into arrays.
inArr = Sheet1.Range("A1:A10").Value2
'Clear all numbers that are not even.
For i = 1 To UBound(inArr, 1)
If inArr(i, 1) Mod 2 <> 0 Then inArr(i, 1) = Empty
Next
'Write cleared array to column C
Sheet1.Range("c1").Resize(UBound(inArr, 1)).Value = inArr
End Sub
If, however, you really do want to remove and resize your array, then a simple way of doing it is to populate a temporary collection first, resizing an output array and then populating that with the collection items. In the example below the code removes all odd numbers and then writes the array to column B - but as an array reduced in size (ie contiguous rows):
Public Sub DeleteItemsAndShrinkArray()
Dim inArr() As Variant, outArr() As Variant
Dim i As Long
Dim temp As Collection
Dim v As Variant
'Read range into arrays.
inArr = Sheet1.Range("A1:A10").Value2
'Keep all even numbers in a temporary collection.
Set temp = New Collection
For i = 1 To UBound(inArr, 1)
If inArr(i, 1) Mod 2 = 0 Then temp.Add inArr(i, 1)
Next
'Dimension the output array.
ReDim outArr(1 To temp.Count, 1 To 1)
'Populate new array from temp collection.
i = 1
For Each v In temp
outArr(i, 1) = v
i = i + 1
Next
'Write reduced array to column B
Sheet1.Range("B1").Resize(UBound(outArr, 1)).Value = outArr
End Sub
Short disclaimer: This is my very first question, so please be understanding.
I'm trying to code a function in Excel VBA that takes a binary number (formatted as a string) that counts the spaces, the 0s, and outputs the consecutive amount of 0s (and adds one to it) until the next "1" in that string appears, with "," in between. At the very end of the string, if there's the a "1", the output should look like: "..., 1". I'll try to make a little easier to understand with an example:
Strings of length twelve:
101011010101 --> 2, 2, 1, 2, 2, 2, 1
110000101101 --> 1, 5, 2, 1, 2, 1
100010001000 --> 4, 4, 4
So far I've managed to make a one-dimensional boolean array that takes the string and splits it into parts of length 1, so to say a "binary array". But I couldn't test it, since I only have half of the function.
Function ABSTAND(str As String, size As Integer) As String
Dim i As Integer
Dim arrays(size) As Boolean
For i = 1 To Len(str)
If Mid(str, i, 1) = "1" Then
arrays(i) = True
Else
arrays(i) = False
End If
'Maybe all of this works in a loop?
'Count consecutive 0s, add one
'Output the value with ", " (Concatenate numbers with strings, or make the number a string)
'Count consecutive 0s again
'and so on...
'Add conditions for the last value: Don't add a ", " and check if a one is the last character
End Function
I know, it looks like I have already figured out the problem and only need to implement it, but I'm new to VBA and don't know that well how it works and how to fix syntax and other problems.
Also, I would like to have a generalized form of my problem, that works with every string length, if that's possible.
Unfortunately, VBA isn't the best language for dealing with arrays. I've written the function as described but it sounds like, from your description, you might want to remove the check for If Len(arrZeroes(i)) > 0 Then etc. because it looks like you want to return '1' values in those cases.
Have a play around with the 'Split' function to try get a better feel for it and how it relates to your problem.
Function ABSTAND(str As String) As String
Dim arrZeroes() As String
Dim arrResult() As String
Dim i As Integer
'Initialise arrResult dimensions
ReDim arrResult(1 To 1)
'Splits your binary number into an array with each element being zero or more 0's
'(if there are several 1's in a row or a 1 at the start or finish it returns 0-length element for that position)
arrZeroes = Split(str, "1")
'Loop through each element in this new array
For i = LBound(arrZeroes) To UBound(arrZeroes)
'Sets the top element of the result array to this length + 1 then increments the size (like appending to array)
arrResult(UBound(arrResult)) = Len(arrZeroes(i)) + 1
ReDim Preserve arrResult(1 To UBound(arrResult) + 1)
Next i
'The last step on the result array incremented its ubound which is still empty so we remove that
ReDim Preserve arrResult(1 To UBound(arrResult) - 1)
'then return the array joined!
ABSTAND = Join(arrResult, ", ")
End Function
Let me know if anything doesn't make sense!
Edit:
An array is basically like an indexed list of elements of a specified data type. The line Dim arrZeroes() as String is dimming a dynamic array of string elements. The benefit of using a dynamic array is that you can dynamically change the amount of elements in it using Redim. To get around the lack of an 'append' function, what you have to do is redim the array to make it one element bigger then set this new biggest element to your new value.
arrResult(UBound(arrResult)) = Len(arrZeroes(i)) + 1
ReDim Preserve arrResult(1 To UBound(arrResult) + 1)
That's what these lines are doing. What the Split function does is, given a string and a delimiter, cut the string into a load of slices at each occurrence of the delimiter and return the array. For example, Split("11101101", "0") returns {"111", "11", "1"}. Where there are more than one occurrence of the delimiter in sequence, or the delimiter appears at the beginning or end of the string, it outputs a zero-length element, such as Split("101101", "1") returns {, "0", , "0",}. What the function is doing is looking at the length of each of these slices (i.e. consecutive digits that are not the delimiter) and outputting them to a new array.
Remove the # in your code.
It is used for preprocessing directive, and you do not need it.
More about Preprocessing directives:
https://msdn.microsoft.com/VBA/Language-Reference-VBA/articles/ifthenelse-directive
In general, try the following code:
Option Explicit
Public Sub TestMe()
Debug.Print ABSTAND("101011010101", 12)
End Sub
Function ABSTAND(str As String, size As Long) As String
Dim i As Long
Dim arrays() As Variant
Dim strResult As String
ReDim arrays(size)
For i = 1 To Len(str)
If Mid(str, i, 1) = "1" Then
arrays(i) = True
Else
arrays(i) = False
End If
strResult = strResult & arrays(i)
Next i
ABSTAND = strResult
End Function
It would print something like TrueFalseTrueFalseTrueTrue... Then try to build up your solution further.
Just some points:
Pay attention how the Array is created.
Use Long instead of Integer.
You can shorten the ABSTAND function, to the following:
Function ABSTAND(str As String, size As Long) As String
Dim i As Long
Dim arrays() As Variant
Dim strResult As String
ReDim arrays(size)
For i = 1 To Len(str)
arrays(i) = Mid(str, i, 1) = "1"
strResult = strResult & arrays(i)
Next i
ABSTAND = strResult
End Function
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 am not entirely sure why I am getting the error message of
Expecting a dynamic array var
with this code:
Option Explicit
Sub ArrayTest()
Dim i As Integer, BankList(0) As Variant, x As Integer
For i = 0 To UBound(ScreenArray)
If ScreenArray(i) Like "TR=SUB*" Then
Debug.Print ScreenArray(i)
ReDim Preserve BankList(x) '<<< ERROR LINE
BankList(x) = ScreenArray(i)
x = x + 1 'Raise the value for the next occurrence, if needed.
End If
Next
End Sub
Basically I am attempting to move specific strings from one array to a new array, if certain criteria are met. It's difficult to determine how many strings will be in the new array until running this For...Next statement.
If you can't tell from the code, the original array is ScreenArray and the new array is BankList.
To create a dynamic array, do not specify the size in the original declaration.
So use BankList() As Variant instead of BankList(0) As Variant.
I know you can easily take a range of cells and slap them into a Variant Array but I want to work with a string array (because it's single-dimensional and takes less memory than a Variant array).
Is there any way to automatically convert a range into a string array?
Right now I am using a function that will take the range and save the values in a variant array, then convert the variant array to a string array. It works nice , but I'm looking for a way to go directly from the range to string array. Any help would be greatly appreciated.
Function RangeToArray(ByVal my_range As Range) As String()
Dim vArray As Variant
Dim sArray() As String
Dim i As Long
vArray = my_range.Value
ReDim sArray(1 To UBound(vArray))
For i = 1 To UBound(vArray)
sArray(i) = vArray(i, 1)
Next
RangeToArray = sArray()
End Function
UPDATE:
It's looking like there is no way to skip the step of throwing the data into a variable array first before converting it to a single-dimensional string array. A shame if it's true (even if it doesn't take much effort, I like to ultra-optimize so I was hoping there was a way to skip that step). I'll close the question in a few days if no solution presents itself. Thanks for the helpful comments, guys!
UPDATE2:
Answer goes to Simon who put in great effort (so did everyone else) and utlimately pointed out it's indeed impossible to go from range to string array in one shot. Thanks, everyone.
You actually can go directly from a range to an array using the functions Split, Join and a delimiter not in the text.
Assuming you have already assigned a 1D range of values as SrcRange
Dim Array() As String: Array = Split(Join(Application.Transpose(SrcRange), "#"), "#")
How about...
Public Function RangeToStringArray(theRange As Excel.Range) As String()
' Get values into a variant array
Dim variantValues As Variant
variantValues = theRange.Value
' Set up a string array for them
Dim stringValues() As String
ReDim stringValues(1 To UBound(variantValues, 1), 1 To UBound(variantValues, 2))
' Put them in there!
Dim columnCounter As Long, rowCounter As Long
For rowCounter = UBound(variantValues, 1) To 1 Step -1
For columnCounter = UBound(variantValues, 2) To 1 Step -1
stringValues(rowCounter, columnCounter) = CStr(variantValues(rowCounter, columnCounter))
Next columnCounter
Next rowCounter
' Return the string array
RangeToStringArray = stringValues
End Function
Function RangeToStringArray(myRange as range) as String()
ReDim strArray(myRange.Cells.Count - 1) As String
Dim idx As Long
Dim c As Range
For Each c In myRange
strArray(idx) = c.Text
idx = idx + 1
Next c
RangeToStringArray = strArray
End Function
If you don't mind altering the contents of the clipboard then:
COPY the range to the clipboard with the Copy method:
MyTargetRange.Copy
Copy the contents from the clipboard to a string variable (search this site or elsewhere for functions to transfer strings to/from the clipboard).
SPLIT the string into a variant array:
MyStringArray = Split(MyClipboardText, vbCrLf)
OPTIONAL: The array will have one additional blank element because there is always an additional Return (vbCrLf) at the end of the text you just copied to the clipboard. To remove simply resize the array:
Redim Preserve MyStringArray(Ubound(MyStringArray) - 1)
Very simple and quick!!!
Drawbacks are that the clipboard may change when you least expect it (during a recalculation) and that it only produces arrays of strings (not Doubles or other numerical value types).
This would be EXTREMELY HELPFUL if you are working with lots of repetitive functions (thousands) that use the same data (thousands of data points). The first time your function is called, do all the intermediate calculations on the ranges of data that you need but save the results in static variables. Also save a string copy of your input ranges via the clipboard. With each subsequent call to your function, convert the input ranges to text, again via the clipboard, and compare with the saved copy. If they are the same you may be able to bypass allot of your preliminary calculations.
Named ranges used in VBA are already arrays. So first make the range into a named range, then refer to it and delete the named range.
For example:
ThisWorkbook.Names.Add Name:="test_array", RefersTo:=Sheet1.Range("A4:B10")
a = Sheet1.Range("test_array")
ThisWorkbook.Names("test_array").Delete