VBA copy values from one array and store them into another - arrays

I am hoping to find help with this current VBA problem. I have looked throughout Stack Overflow and other Google searches, but can't seem to find what I'm looking for.
Essentially, I have a user pasted value on my page which I am delimiting on a comma, and then storing that into an array. What I am aiming to do is then loop through that array and eliminate any extra spaces, and then also delete any values that AREN'T a number.
Copy user values
Store into an array
Erase whitespace
So far, I have not been able to:
Copy items that ARE a number to new array
Currently, my code looks like:
Sub grabText()
' This macro was written as a test macro to grab and filter data entered in a textbox
Application.ScreenUpdating = False
Dim enteredValue As String ' Value taken from page
Dim vals() As String ' Array once it is split
Dim goodvals() As String 'Formatted array
Dim i As Integer 'Index
enteredValue = ActiveSheet.myTxt.Text
' MsgBox enteredValue
vals() = Split(enteredValue, ",")
lastitem = UBound(vals)
' MsgBox lastitem
'Formats array
For i = LBound(vals) To UBound(vals)
i = TRIM(vals(i))
'
' If (ISNUMBER(vals(i)) == TRUE) Then
' enter i into goodvals()
'
Next i
Application.ScreenUpdating = True
Any help or advice would be greatly appreciated. I was thinking about ways to do this in other languages (Java, Python) and I was thinking about Linked-Lists.
Thanks in advance!

Some issues:
Don't assign the result of Split to vals(), but to vals
Don't re-use the variable i for the result of the Trim. It is better to use a separate variable for that, which you can then type as a String
You can capture the desired result if you
First reserve enough room for your target array: it can never be longer than the Split result, so use that as the initial size
Use a separate index variable for referencing the target array index, and only increment it when you have stored a number in it
Finally reduce the size of the target array to the size that was actually used
Code:
Dim enteredValue As String ' Value taken from page
Dim vals() As String ' Array once it is split
Dim goodvals() As String 'Formatted array
Dim i As Long 'Index in vals
Dim j As Long 'Index in goodvals
Dim s As String 'Individual string
enteredValue = ActiveSheet.myTxt.Text
vals = Split(enteredValue, ",")
' Reserve as many entries in the target array
ReDim goodvals(UBound(vals))
j = LBound(goodvals)
For i = LBound(vals) To UBound(vals)
s = Trim(vals(i))
If IsNumeric(s) Then
goodvals(j) = CDbl(s)
MsgBox goodvals(j)
j = j + 1
End If
Next
' Shorten the array size to the part that is used
If j Then
ReDim Preserve goodvals(j - 1)
Else ' There were no numericals at all, so erase the array:
Erase goodvals
End If

Related

How to speed up extracting numbers from chemical formula

I have been using some useful VBA code by PEH that uses regular expression to extract the number of instances of a specific element in a chemical formula, see: https://stackoverflow.com/a/46091904/17194644
It works well, but everything slows down when I use the function hundreds of times in one worksheet. I was wondering if this might be due to the time it takes VBA to read/write values from/to the cells, so I created an array function (based on the regex code by PEH) to see if it would speed things up, see below. The function works and is quicker but can still slow things down when dealing with hundreds of values, and I cannot get the second part to work that finds multiplies elements within parenthesis. Any thoughts on how to improve further?
Function CountElements(ChemFormulaRange As Variant, ElementRange As Variant) As Variant
'define variables
Dim RetValRange() As Long
Dim RetVal As Long
Dim ChemFormula As String
Dim npoints As Long
Dim i As Long
Dim mpoints As Long
Dim j As Long
' Convert input ranges to variant arrays
If TypeName(ChemFormulaRange) = "Range" Then ChemFormulaRange = ChemFormulaRange.Value
If TypeName(ElementRange) = "Range" Then ElementRange = ElementRange.Value
'parameter
npoints = UBound(ChemFormulaRange, 1) - LBound(ChemFormulaRange, 1) + 1
mpoints = UBound(ElementRange, 2) - LBound(ElementRange, 2) + 1
'dimension arrays
ReDim RetValRange(1 To npoints, 1 To mpoints)
'calculate all values
For j = 1 To mpoints
Element = ElementRange(1, j)
For i = 1 To npoints
RetVal = 0
ChemFormula = ChemFormulaRange(i, 1)
Call ChemRegex(ChemFormula, Element, RetVal)
RetValRange(i, j) = RetVal
Next i
Next j
'output answer
CountElements = RetValRange
End Function
Private Sub ChemRegex(ChemFormula, Element, RetVal)
Dim regEx As New RegExp
With regEx
.Global = True
.MultiLine = True
.IgnoreCase = False
End With
'first pattern matches every element once
regEx.Pattern = "([A][cglmrstu]|[B][aehikr]?|[C][adeflmnorsu]?|[D][bsy]|[E][rsu]|[F][elmr]?|[G][ade]|[H][efgos]?|[I][nr]?|[K][r]?|[L][airuv]|[M][cdgnot]|[N][abdehiop]?|[O][gs]?|[P][abdmortu]?|[R][abefghnu]|[S][bcegimnr]?|[T][abcehilms]|[U]|[V]|[W]|[X][e]|[Y][b]?|[Z][nr])([0-9]*)"
Dim Matches As MatchCollection
Set Matches = regEx.Execute(ChemFormula)
Dim m As Match
For Each m In Matches
If m.SubMatches(0) = Element Then
RetVal = RetVal + IIf(Not m.SubMatches(1) = vbNullString, m.SubMatches(1), 1)
End If
Next m
'second patternd finds parenthesis and multiplies elements within
' regEx.Pattern = "(\((.+?)\)([0-9])+)+?"
' Set Matches = regEx.Execute(ChemFormula)
' For Each m In Matches
' RetVal = RetVal + ChemFormula(m.SubMatches(1), Element) * (m.SubMatches(2) - 1) '-1 because all elements were already counted once in the first pattern
' Next m
End Sub
If you are using Office 365, then you do not need VBA. A formula can achieve what you want and I think it would be faster.
=TRIM(TEXTJOIN("",TRUE,IFERROR((MID(A1,ROW(INDIRECT("1:"&LEN(A1))),1)*1)," ")))
Note: If you still need a VBA solution then remember you can enter the above formula in the entire range in one go and then convert it to values.
rng.Formula = "=TRIM(TEXTJOIN("""",TRUE,IFERROR((MID(A1,ROW(INDIRECT(""1:""&LEN(A1))),1)*1),"" "")))"
rng.Value = rng.Value
The slowest part of your ChemRegex routine is creating the RegExp object.
If all your cells are passed to CountElements as a pair of large areas move the code that creates the RegExp object and applies a few properties from ChemRegex to CountElements, and pass the RegExp reference from CountElements to ChemRegex.
Or, if you are calling CountElements as say a UDF in multiple cells, declare RegExp at module level
Private RegEx as RegExp
In CountElements...
If RegEx is Nothing Then
Set RegEx = New RegExp
' apply the properties
End If
' code
' and pass RegEx to ChemRegex
Call ChemRegex(ChemFormula, Element, RetVal, RegEx)
Isolate all numbers in chemical formula
Just for the sake of the art an alternative to Siddharth 's approach, where I demonstrate how to use Match() comparing
an array of each formula character|digit in the given string with
an array of all regular digits.
This allows to identify array elements (here: digits) based on their position. So this demo might be also helpful to solve similar requirements. - I don't pretend this to be a better or faster way.
Function ChemNo(ByVal s As String) As Variant
'Purp: return array of found character positions in chars string
'Note: (non-findings show Error 2042; can be identified by IsError + Not IsNumeric)
Dim digits
digits = String2Arr("1234567890")
'get any digit position within array digits ' note: zero position returns 10
Dim tmp
tmp = Application.Match(String2Arr(s), digits, 0)
'check for digits in a loop through tmp
Dim i As Long, ii As Long
For i = 1 To UBound(tmp)
If IsNumeric(tmp(i)) Then ' found digit
tmp(i) = tmp(i) Mod 10 ' get digtis including zeros
If IsNumeric(tmp(i - 1)) Then ' check preceding digit
tmp(i) = 10 * tmp(i - 1) + tmp(i) ' complete number
tmp(i - 1) = "!" ' mark former digit
End If
Else
tmp(i) = "!" ' mark non-numeric element
End If
Next i
ChemNo = Filter(tmp, "!", False) ' delete marked elements
End Function
Help function String2Arr()
Assigns an array of single characters after atomizing a string input:
Function String2Arr(ByVal s As String) As Variant
'Purp: return array of all single characters in a string
'Idea: https://stackoverflow.com/questions/13195583/split-string-into-array-of-characters
s = StrConv(s, vbUnicode)
String2Arr = Split(s, vbNullChar, Len(s) \ 2)
End Function
If you want to use the function as tabular input profiting from the newer dynamic features in Excel, you may enter it as user defined function e.g. in cell B1: =ChemNo(A1) displaying each number horizontally in as so called spill range. Using older versions, I suppose you'd need a CSE entry (Ctrl↑┘) to mark it as {array} formula.

Excel VBA Function Not Finding Exact Match in Array [duplicate]

If UBound(Filter(myArray, Sheets(i).Cells(1, j).Value, True)) = -1 Then
'take action
End if
I used this syntax to compare an element found in Cells(1, j) (e.g. "ally") to all the elements of an array (e.g. "mally", "kate", "becks"), and to take action when no exact match is found.
Trouble is, based on this line of code it seems "ally" is considered as matching "mally" (probably because "ally" is a substring from "mally"), whereas I want "ally" to be recognised as distinct from "mally".
Any help with the syntax as to achieve this? Thank you!
IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))
Filter will return any items that partially match. The work around suggested by Microsoft is to then search the filtered array for exact matches.
Function FilterExactMatch(astrItems() As String, _
strSearch As String) As String()
' This function searches a string array for elements
' that exactly match the search string.
Dim astrFilter() As String
Dim astrTemp() As String
Dim lngUpper As Long
Dim lngLower As Long
Dim lngIndex As Long
Dim lngCount As Long
' Filter array for search string.
astrFilter = Filter(astrItems, strSearch)
' Store upper and lower bounds of resulting array.
lngUpper = UBound(astrFilter)
lngLower = LBound(astrFilter)
' Resize temporary array to be same size.
ReDim astrTemp(lngLower To lngUpper)
' Loop through each element in filtered array.
For lngIndex = lngLower To lngUpper
' Check that element matches search string exactly.
If astrFilter(lngIndex) = strSearch Then
' Store elements that match exactly in another array.
astrTemp(lngCount) = strSearch
lngCount = lngCount + 1
End If
Next lngIndex
' Resize array containing exact matches.
ReDim Preserve astrTemp(lngLower To lngCount - 1)
' Return array containing exact matches.
FilterExactMatch = astrTemp
End Function
This code is taken from http://msdn.microsoft.com/en-us/library/office/aa164525%28v=office.10%29.aspx
If the array is only used for this comparison and not needed for anything else you could also force full word comparisons by adding your own delimiters that never appear in the data - maybe square brackets.
So if you change your array to contain "[mally]", "[kate]", "[becks]"
then your condition becomes:
If UBound(Filter(myArray, "[" & Sheets(i).Cells(1, j).Value & "]", True)) = -1
If you do not need to use Filter then the below snippet would work
Dim v
Dim bMatch As Boolean
bMatch = False
For Each v In myArray
'compare strings
If StrComp(CStr(v), Sheets(i).Cells(1, j).Value, vbTextCompare) = 0 Then
bMatch = True
End If
Next
If Not bMatch Then
'do something
End If

VBA Insert value to array replacing value instead of inserting

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.

Excel VBA: Adding Array to Form Control Combobox

I have several files I want to combine and analyse with one results file. One of those files contains samples with different names that are repeated an unknown amount of times. I want to extact all unknown names from this file and add them to a dropdown box (Form Control Combobox).
To simplify things I added the following strings to the first column a sheet in a new Excel file:
String 1
String 1
String 2
String 3
String 3
String 3
String 4
String 4
to extract the unique strings, I wrote the following piece of code:
Sub MakeArrayInDropDown()
' Declare variables
Dim myArray() As Variant ' Array with undefined size
Dim i As Integer ' Counter for-loop
Dim i_UnStr As Integer ' Counter of unique strings
Dim i_lastStr As Integer ' Length of strings in column A
Dim wb As Workbook ' Short workbookname
Dim ws As Worksheet ' Short worksheet name
Dim TC As Range ' Target Cell (TC)
' Set workbook and worksheet
Set wb = ThisWorkbook
Set ws = ActiveSheet
' Set cell where all unique strings should go to
Set TC = ws.Cells(1, 3)
' Determine amount of strings in column A
i_lastStr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' Go through all strings that are in column A
For i = 1 To i_lastStr
' Save the first string in the first position of the array
If i_UnStr = 0 Then
i_UnStr = 1
ReDim myArray(i_UnStr) ' Resize array to 1
myArray(i_UnStr) = ws.Cells(i, 1) ' Add first string to array
' Add if next string is different from the string previously added
ElseIf Not StrComp(myArray(i_UnStr), ws.Cells(i, 1)) = 0 Then
' Increase unique strings counter
i_UnStr = i_UnStr + 1
' Resize array to no unique strings, preserving precious values
ReDim Preserve myArray(i_UnStr)
' Add next unique string to array as well
myArray(i_UnStr) = ws.Cells(i, 1)
End If
Next i
' Add Form Control dropdown to target cell
ws.DropDowns.Add(TC.Left, TC.Top, TC.Width, TC.Height).Name = "dropdown_row" & TC.Row
wb.Worksheets("Sheet1").Shapes("dropdown_row" & TC.Row).ControlFormat.List = myArray
End Sub
Unfortunately, this code results in the following error:
Runtime error 1004: Unable to set the List property of the Dropdown class
I don't understand what is wrong withmy array, because if I change the last line into
wb.Worksheets("Sheet1").Shapes("dropdown_row" & TC.Row).ControlFormat.List = _
Array(myArray(1), myArray(2), myArray(3), myArray(4))
Everything works perfectly fine. It seems like my array is not accepted as such...
Also, initially I wrote the last line like this
ws.Shapes("dropdown_row" & TC.Row).ControlFormat.List = myArray
But that gave me:
Runtime error 424: object required
Can anybody explain me why any of these two things are wrong? Thanks a lot!
I've tested your code and my observations as follows:
The DropDown shape does not like the Empty value at index 0 of your array. It seems that you are not able to use mixed type in the array you're passing to the .List method, because even if I change the Empty value to an integer, it fails with the same error.
Regarding why this statement works:
wb.Worksheets("Sheet1").Shapes("dropdown_row" & TC.Row).ControlFormat.List = _
Array(myArray(1), myArray(2), myArray(3), myArray(4))
The above works because you're passing an array that avoids the pitfall mentioned above, because you're explicitly not passing the Empty value.
Note: Strictly speaking, there is no need for you to ReDim your array when i_UnStr = 0, arrays are normally base 0, so you can just work with it that way.
Alternatively, you can force a null string in to the first array item, and this should work:
myArray(0) = vbNullString
ws.Shapes("dropdown_row" & TC.Row).ControlFormat.List = myArray
So, the solution is to avoid mixed data type (and possibly also the unnecessary empty element in the array), or if you need a "blank", you need to assign it as an empty string either vbNullString or literal "".
In terms of optimisation, I'd avoid the array altogether especially if the data is large, because ReDim Preserve is usually a rather expensive statement.
Sub MakeArrayInDropDown()
' Declare variables
Dim i As Integer ' Counter for-loop
Dim i_lastStr As Integer ' Length of strings in column A
Dim wb As Workbook ' Short workbookname
Dim ws As Worksheet ' Short worksheet name
Dim TC As Range ' Target Cell (TC)
Dim DD As Shape ' Dropdown shape
' Set workbook and worksheet
Set wb = ThisWorkbook
Set ws = ActiveSheet
' Set cell where all unique strings should go to
Set TC = ws.Cells(1, 3)
' Determine amount of strings in column A
i_lastStr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
' Add Form Control dropdown to target cell
Set DD = ws.DropDowns.Add(TC.Left, TC.Top, TC.Width, TC.Height)
DD.Name = "dropdown_row" & TC.Row
DD.AddItem "" 'Adds a blank entry in the first row of the dropdown
DD.AddItem ws.Cells(i,1).Value
For i = 2 To i_lastStr
' Add if next string is different from the string previously added
ElseIf Not StrComp(ws.Cells(i-1, 1), ws.Cells(i, 1)) = 0 Then
DD.AddItem ws.Cells(i, 1).Value
End If
Next i
End Sub
Please, Try this:
ws.Shapes("dropdown_row" & TC.Row).OLEFormat.Object.List = myArray

How to extract a part of array by referring start and end index just like what we do in Matlab

For example, if we have an array A.
In matlab, we just use A[a:b] to get a sub array easily,where a,b are start point and end point respectively.
Is there similar way to do it in VBA?
Thanks
Working with arrays is incredibly fast so this will probably give no discernable benefit - although I can understand how it may appeal from a coding sense than looping to fill a smaller array
Given you are working with a single element array you could:
Introduce a "marker" string inside the large array.
Join the large array with a delimiter into a single string.
Split the large array by the "marker" string, then separate the reduced string into a smaller array with the delimiter.
The code below dumps the numbers 1 to 100 into an array, and then splits it as above to pull out the first 10 records.
Sub test()
Dim bigArr
Dim subArr
Dim strSep As String
Dim strDelim As String
Dim strNew As String
Dim rowBegin As Long
Dim rowEnd As Long
strDelim = ","
strSep = "||"
'fill array with 1 to 100
bigArr = Application.Transpose(Application.Evaluate("row(1:100)"))
rowBegin = 1
rowEnd = 10
bigArr(rowEnd + 1) = strSep
'make a single string
strNew = Join(bigArr, strDelim)
'split the string at the marker
vArr = Split(strNew, strSep)
ReDim subArr(rowBegin To rowEnd)
'split the smaller string with the desired records
subArr = Split(Left$(vArr(0), Len(vArr(0)) - 1), strDelim)
End Sub

Resources