I wish to use an Excel array function to generate an array of strings and then pass this to a user defined function to strip blanks and concatenate the strings separated by a ",".
I have a function that does this when called from a VBA macro. When I try to use it as a user defined function, e.g. =ConcStr({"A","B","C"}), I get a #Value! error.
Function is below:
Sub StrTest()
Dim StaticArray(1 To 3) As String
Dim Result As String
StaticArray(1) = "A"
StaticArray(2) = "B"
StaticArray(3) = "C"
Result = ConcStr(Arr:=StaticArray)
MsgBox Result
End Sub
Function ConcStr(Arr() As String) As String
MsgBox "started"
Dim N As Long
Dim Total As String
For N = LBound(Arr) To UBound(Arr)
MsgBox Arr(N)
Total = Total & "," & Arr(N)
Next N
ConcStr = Total
End Function
If you rewrite your UDF to accept a Variant instead, it should work. Also, you can just use the Join function to accomplish what you need:
Function ConcStr(arr As Variant) As String
ConcStr = Join(arr, ",")
End Function
Declare, dim, assign and pass the array over as a variant.
Sub StrTest()
Dim StaticArray As Variant, Result As String
ReDim StaticArray(1 To 3)
StaticArray(1) = "A"
StaticArray(2) = "B"
StaticArray(3) = "C"
Result = ConcStr(Arr:=StaticArray)
MsgBox Result
Result = ConcStr2(Arr:=StaticArray)
MsgBox Result
End Sub
Function ConcStr(Arr As Variant) As String
MsgBox "started"
Dim N As Long, Total As String
For N = LBound(Arr) To UBound(Arr)
MsgBox Arr(N)
Total = Total & "," & Arr(N)
Next N
ConcStr = Mid(Total, 2) 'Mid to get rid of the first comma
End Function
Function ConcStr2(Arr As Variant) As String
'could just be like this,
ConcStr2 = Join(Arr, ",")
End Function
I've added an alternative Join Function version to simplfy things and modified your function with the Mid function to remove the leading comma.
I was able to get what you want with:
Public Function ConcatString(ByVal arr As Variant) As String
ConcatString = vbNullString
Dim i As Long, n As Long, z as Long
z = LBound(arr) : n = UBound(arr)
For i = z To n
ConcatString = ConcatString + arr(i)
Next i
End Function
Related
I have a column where almost every cell is made of a combination of numbers and letters and symbols ("TS-403" or "TSM-7600"). I want every char that's not an integer to be deleted/replaced with an empty string, so that I'm left only with numbers ("403").
I've thought up of two approaches:
I think the best one is to create an array of integers with the numbers 0-9, and then iterate through the cells with a for loop where if the string in a cell contains a char that's not in the array, then that symbol (not the entire cell) should be erased.
Sub fixRequestNmrs()
Dim intArr() as Integer
ReDim intArr(1 to 10)
For i = 0 to 9
intArr(i) = i
Next i
Dim bRange as Range
Set bRange = Sheets(1).Columns(2)
For Each cell in bRange.Cells
if cell.Value
// if cell includes char that is not in the intArr,
// then that char should be deleted/replaced.
...
End Sub()
Perhaps the second approach is easier, which would be to use the Split() function as the '-' is always followed by the numbers, and then have that first substring replaced with "". I'm very confused on how to use the Split() function in combination with a range and a replace funtion though...
For Each cell in bRange.Cells
Cells.Split(?, "-")
...
Digits to Integer Using the Like Operator
The Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns an integer composed from the digits of a string.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DigitsToInteger(ByVal SearchString As String) As Long
Dim ResultString As String
Dim Char As String
Dim n As Long
For n = 1 To Len(SearchString)
Char = Mid(SearchString, n, 1)
If Char Like "[0-9]" Then ResultString = ResultString & Char
Next n
If Len(ResultString) = 0 Then Exit Function
DigitsToInteger = CLng(ResultString)
End Function
A Worksheet Example
Sub DigitsToIntegerTEST()
Const FIRST_ROW As Long = 2
' Read: Reference the (single-column) range.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
If LastRow < FIRST_ROW Then Exit Sub ' no data
Dim rg As Range: Set rg = ws.Range("B2", ws.Cells(LastRow, "B"))
Dim rCount As Long: rCount = rg.Rows.Count
' Read: Return the values from the range in an array.
Dim Data() As Variant
If rCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
Else
Data = rg.Value
End If
' Modify: Use the function to replace the values with integers.
Dim r As Long
For r = 1 To rCount
Data(r, 1) = DigitsToInteger(CStr(Data(r, 1)))
Next r
' Write: Return the modifed values in the range.
rg.Value = Data
' To test the results in the column adjacent to the right, instead use:
'rg.Offset(, 1).Value = Data
End Sub
In VBA (Simple)
Sub DigitsToIntegerSimpleTest()
Const S As String = "TSM-7600sdf"
Debug.Print DigitsToInteger(S) ' Result 7600
End Sub
In Excel
=DigitsToInteger(A1)
If you have the CONCAT function, you can do this with a relatively simple formula -- no VBA needed:
=CONCAT(IFERROR(--MID(A1,SEQUENCE(LEN(A1)),1),""))
If you prefer a non-VBA solution in an earlier version of Excel, there is a more complex formula available, but I'd have to go back through my files to locate it.
A tricky function GetVal()
The following function
translates a string into a single characters array arr via help function String2Arr()
isolates them into numeric (category code 6) or non-numeric categories (other) via a tricky execution of Application.Match (here without its 3rd argument which is mostly used for precise search, and by comparing two arrays)
finds the starting position in the original string via Instr()
returns the value of the right substring via Val() (~> see note).
Function GetVal(ByVal s As String) As Double
Dim arr: arr = String2Arr(s): Debug.Print Join(arr, "|")
Dim chars: chars = Split(" ,',+,-,.,0,A", ",")
Dim catCodes: catCodes = Application.Match(arr, chars) 'No 3rd zero-argument!!
Dim tmp$: tmp = Join(catCodes, ""): Debug.Print Join(catCodes, "|")
Dim pos&: pos = InStr(tmp, 6) ' Pos 6: Digits; pos 1-5,7: other symbols/chars
GetVal = Val(Mid(s, pos)) ' calculate value of right substring
End Function
Notes
The Val function can translate a (sub)string with starting digits to a number, even if there are following non-numeric characters.
Help function String2Arr()
Atomizes a string into a single characters array:
Function String2Arr(ByVal s As String)
s = StrConv(s, vbUnicode)
String2Arr = Split(s, vbNullChar, Len(s) \ 2)
End Function
Example call
Dim s As String
s = "aA+*&$%(y#,'/\)!-12034.56blabla"
Debug.Print GetVal(s) ' ~~> 12034.56
I have code to ask a user for a series of codes that then creates a single-dimensional array like this:
Dim strDaysTimes As String
Dim arrDaysTimes() As String
strDaysTimes = InputBox("What days and times do you want to schedule meetings for? (write as 6c,7b)", "Enter Days and Times")
arrDaysTimes() = Split(strDaysTimes, ",")
The number of inputs is not defined but the format is. It could be "6c,7b" or "5a,6b,7b".
I want to convert this into a multi-dimensional array that would carry the values like this (one dimension has the number portion and the other has the letter portion):
5 a
6 b
7 b
I know that I need to use a nested For...Next statements to process multidimensional arrays, but I would appreciate any suggestions.
Use ReDim:
Public Function DivideArray()
Dim strDaysTimes As String
Dim arrDaysTimes() As String
Dim DaysTimes() As String
Dim Index As Integer
strDaysTimes = InputBox("What days and times do you want to schedule meetings for? (write as 6c,7b)", "Enter Days and Times")
arrDaysTimes() = Split(strDaysTimes, ",")
ReDim DaysTimes(UBound(arrDaysTimes) - LBound(arrDaysTimes) + 1, 0 To 1)
For Index = LBound(arrDaysTimes) To UBound(arrDaysTimes)
DaysTimes(Index, 0) = Left(LTrim(arrDaysTimes(Index)), 1)
DaysTimes(Index, 1) = Right(RTrim(arrDaysTimes(Index)), 1)
Next
For Index = LBound(arrDaysTimes) To UBound(arrDaysTimes)
Debug.Print DaysTimes(Index, 0), DaysTimes(Index, 1)
Next
End Function
Input example:
a7, b8, c9
Output:
a 7
b 8
c 9
Just for the sake of the art an alternative to #Gustav 's approach with the bonus that it returns token lengths greater than 1, too.
Furthermore it profits from the fact that the Val() function is able to return
a) the starting numeric value from an input string and
b) the closing string by a split via the above numeric value as delimiter.
Public Function tokenize(ByVal s As String)
Dim arr() As String
arr() = Split(Trim(s), ",")
Dim tmp() As String
ReDim tmp(0 To UBound(arr) - LBound(arr), 0 To 1)
Dim i As Long
For i = LBound(arr) To UBound(arr)
Dim num: num = Val(arr(i))
tmp(i, 0) = num
tmp(i, 1) = Split(arr(i), num)(1)
Next
tokenize = tmp
End Function
Example call
Sub testTokenize()
'0. Get input string (e.g. "6c,7b")
Dim strDaysTimes As String
strDaysTimes = InputBox( _
"What days and times do you want to schedule meetings for? (write as 6c,7b)", _
"Enter Days and Times", _
"6c,7b")
'1. Call help function
Dim results As Variant
results = tokenize(strDaysTimes) ' << function tokenize()
'2. Show results in VB Editor's immediate window
Dim i As Long
For i = LBound(results) To UBound(results)
Debug.Print results(i, 0), results(i, 1)
Next
End Sub
The following code will help you get there.
The GetDaysAndTimes function will return a Jagged array (i.e. an array of arrays). This means that to get the Day and Time of Item 3 you would use ArrayName(2)(0) and ArrayName(2)(1) where arrayname is the name of the array you are using (arrayDaysTimes?)
The function SplitAlphaNumString allows users to enter codes such as AB23.
Option Explicit
' This function takes the string returned by your input box
Public Function GetDaysAndTimes(ByRef ipString As String) As Variant
Dim myItems As Variant
myItems = VBA.Split(ipString, ",")
Dim myDayTimes As Variant
Dim myindex As Long
For myindex = LBound(myItems) To UBound(myItems)
myDayTimes(myindex) = SplitAlphaNumString(myItems(myindex))
Next
GetDaysAndTimes = myDayTimes
End Function
Public Function SplitAlphaNumString(ByVal ipString As String) As Variant
Dim myindex As Long
For myindex = 1 To VBA.Len(ipString)
If VBA.Asc(VBA.Mid(ipString, myindex, 1)) < 58 Then
Dim myAlphas As String
myAlphas = VBA.Mid(ipString, 1, myindex - 1)
Dim myNums As String
myNums = VBA.Mid(ipString, myindex)
SplitAlphaNumString = Array(myAlphas, myNums)
Exit Function
End If
Next
End Function
Sub Test()
Dim myArray As Variant
myArray = SplitAlphaNumString("D5")
Debug.Print myArray(0), myArray(1)
End Sub
I need a function, which searches some strings within different arrays within one single string.
Let's say, I have the word "building" and two lists (= two arrays):
1. house, garage, tower, castle, building
2. table, bed, flowers, picture
So, in this case list 1 contains the regarding word and should therefore responded.
My code so far (one dimensional array):
Function cbsMatchKeywords(strKeyword As String, ParamArray strList() As Variant) As String
Dim i As Long
For i = LBound(strList,1) + 1 To UBound(strList,1)
If InStr(strKeyword, strList(i,1)) > 0 Then
cbsMatchKeywords = cbsMatchKeywords & strList(i,1)
End If
Next i
End Function
Any ideas?
This will work for you
Function cbsMatchKeywords(strKeyword As String, ParamArray strList() As Variant) As String
Dim i As Long, j As Long
For j = LBound(strList, 2) To UBound(strList, 2)
For i = LBound(strList, 1) + 1 To UBound(strList, 1)
If InStr(strKeyword, strList(i, j)) > 0 Then
cbsMatchKeywords = cbsMatchKeywords & strList(i, j)
End If
Next i
Next j
End Function
Option Explicit
Public Sub Main()
Dim arr1 As Variant
arr1 = Array("house", "garage", "tower", "castle", "building")
Dim arr2 As Variant
arr2 = Array("table", "bed", "flowers", "picture")
Const keyword As String = "building"
Dim result As String
result = cbsMatchKeywords(keyword, arr1, arr2)
Debug.Print "Result is : '" & result & "'"
' Prints:
' Result is : 'building'
End Sub
Function cbsMatchKeywords( _
strKeyword As String, _
ParamArray strList() As Variant) As String
Dim i As Integer
Dim j As Integer
Dim arr As Variant
For i = LBound(strList) To UBound(strList)
arr = strList(i)
If Not IsArray(arr) Then _
GoTo continue
For j = LBound(arr) To UBound(arr)
If InStr(strKeyword, arr(j)) > 0 Then
cbsMatchKeywords = cbsMatchKeywords & arr(j)
End If
Next j
continue:
Next i
End Function
I have an array that I gathered from a code that splits and then slices an array.
Refer to this question: Split multidimensional array and then slice it
I have added this line of code: splitted = Application.Transpose(splitted)
Now the array is defined the following way:
When I try to run the following code:
For r = LBound(splitted) To UBound(splitted)
Debug.Print uniqueValues(splitted(r))
Next r
I get this error: run time error 9 subscript out of range
For reference with the original code, I receive this output:
It works fine with my function and I can only imagine that it has to do with the difference in the definition of the array.
The function requires this input: Function uniqueValues(uniqueArray As Variant) As Integer:
Function uniqueValues(uniqueArray As Variant) As Integer
Dim arr As New Collection, a
Dim i As Long
On Error Resume Next
For Each a In uniqueArray
arr.Add a, a
Next
uniqueValues = arr.Count
End Function
This is the code from the function that dee provided:
Sub SplitMe()
Dim source As Variant, tempArr As Variant
source = ActiveSheet.Range("A3:A5")
If Not IsArray(source) Then _
Exit Sub
Dim r As Integer
Dim parts() As String
Dim splitted As Variant
ReDim splitted(LBound(source) To UBound(source))
For r = LBound(source) To UBound(source)
parts = VBA.Split(source(r, 1), "\")
splitted(r) = parts
Next r
splitted = Application.Transpose(splitted)
'ReDim tempArr(LBound(splitted) To UBound(splitted))
'tempArr = Application.Index(splitted, 0, 1)
For r = LBound(splitted) To UBound(splitted)
Debug.Print uniqueValues(splitted(r))
Next r
End Sub
Try this:
Sub SplitMe()
Dim source As Variant, tempArr As Variant
source = ActiveSheet.Range("A3:A5")
If Not IsArray(source) Then _
Exit Sub
Dim r As Integer
Dim parts() As String
Dim splitted As Variant
ReDim splitted(LBound(source) To UBound(source))
For r = LBound(source) To UBound(source)
parts = VBA.Split(source(r, 1), "\")
splitted(r) = parts
Next r
splitted = Application.Transpose(splitted)
For r = LBound(splitted, 1) To UBound(splitted, 1)
Debug.Print uniqueValues(splitted, r)
Next r
End Sub
Function uniqueValues(uniqueArray As Variant, indx As Integer) As Integer
Dim arr As New Collection, a, s As String
Dim i As Long
On Error Resume Next
For i = LBound(uniqueArray, 2) To UBound(uniqueArray, 2)
a = uniqueArray(indx, i)
s = s & IIf(s <> "", ", ", "") & a
arr.Add a, a
Next
Debug.Print s, arr.Count
uniqueValues = arr.Count
End Function
how do i filter an array using another array vb6
Edit
given an array A, remove all elements in array B from array A
In that case, I'd just sort one array, then iterate through the second, deleting things from the first array if they are found. This algorithm seems to take O(n lg n) and does what you want it to do.
Assuming they are integer arrays:
Dim FilteredArray() As Integer
Dim X as Long
Dim Y as Long
Dim Z as Long
Dim bDupe as Boolean
Z = -1
For X = 0 to UBound(A)
bDupe = False
For Y = 0 to UBound(B)
If A(X) = B(Y) Then
bDupe = True
Exit For
End If
Next
If Not bDupe Then
Z = Z + 1
ReDim Preserve FilteredArray(Z)
FilteredArray(Z) = A(X)
End If
Next
Try something like this
Option Explicit
Private Sub Form_Load()
Dim vElem As Variant
For Each vElem In SubstractArray(Array("aa", "b", "test"), Array("c", "aa", "test"))
Debug.Print vElem
Next
End Sub
Private Function SubstractArray(arrSrc As Variant, arrBy As Variant) As Variant
Dim cIndex As Collection
Dim vElem As Variant
Dim vRetVal As Variant
Dim lIdx As Long
If UBound(arrSrc) < LBound(arrSrc) Then
Exit Function
End If
'--- build index collection
Set cIndex = New Collection
For Each vElem In arrBy
cIndex.Add vElem, "#" & vElem
Next
'--- allocate output array
lIdx = LBound(arrSrc)
ReDim vRetVal(lIdx To UBound(arrSrc)) As Variant
'--- iterate source and seek in index
For Each vElem In arrSrc
On Error Resume Next
IsObject cIndex("#" & vElem)
If Err.Number <> 0 Then
vRetVal(lIdx) = vElem
lIdx = lIdx + 1
End If
On Error GoTo 0
Next
'--- shrink output array
If lIdx = LBound(vRetVal) Then
vRetVal = Split(vbNullString)
Else
ReDim Preserve vRetVal(0 To lIdx - 1) As Variant
End If
SubstractArray = vRetVal
End Function
i have found the answer myself, thanks for all who contributed
Function FilterArray(ByVal Source As String, ByVal Search As String, Optional _
ByVal Keep As Boolean = True) As String
Dim i As Long
Dim SearchArray() As String
Dim iSearchLower As Long
Dim iSearchUpper As Long
If LenB(Source) <> 0 And LenB(Search) <> 0 Then
SearchArray = Split(Search, " ")
Else
FilterArray = Source
Exit Function
End If
iSearchLower = LBound(SearchArray)
iSearchUpper = UBound(SearchArray)
For i = iSearchLower To iSearchUpper
DoEvents
Source = Join(Filter(Split(Source, " "), SearchArray(i), Keep, _
vbTextCompare), " ")
Next i
FilterArray = Source
End Function