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
Related
for belows code the line vItemsNotInMaster(k) = vCheckItems(i) throws a type mismatch error once the array vItemsNotInMaster shall be populated. I am not sure why - as the caller sub and function array variables are all declared as Variants and types did not change according to the Locals Window.
I tried different data types but, this does throw other error messages.
Public Sub Testing()
Dim myArray1(1 To 4) As Variant
Dim myArray2(1 To 4) As Variant
Dim myArray3 As Variant
myArray1(1) = "one1"
myArray1(2) = "two3"
myArray1(3) = "three5"
myArray1(4) = "four7"
myArray2(1) = "one1"
myArray2(2) = "two3"
myArray2(3) = "different"
myArray2(4) = "four7"
myArray3 = Comparing_TwoArrays(myArray1, myArray2)
Stop
End Sub
Public Function Comparing_TwoArrays(ByVal vCheckItems As Variant, ByVal vMasterList As Variant) As Variant
Dim vItemsNotInMaster As Variant
Dim isMatch As Boolean
Dim i As Integer
Dim j As Integer
Dim k As Integer
ReDim vArray3(1 To UBound(vCheckItems, 1) + UBound(vMasterList, 1))
k = 1
For i = LBound(vCheckItems, 1) To UBound(vCheckItems, 1)
isMatch = False
For j = LBound(vMasterList, 1) To UBound(vMasterList, 1)
If vCheckItems(i) = vMasterList(j) Then
isMatch = True
Exit For
End If
Next j
If (isMatch = False) Then
vItemsNotInMaster(k) = vCheckItems(i) '---> Throws type mismatch
k = k + 1
End If
Next i
If (k > 1) Then
ReDim Preserve vArray3(1 To k - 1)
Else
vArray3 = Empty
End If
Comparing_TwoArrays = vArray3
End Function
Does someone has an idea?
Code Example credited to: https://bettersolutions.com/vba/arrays/comparing.htm
As I said in my comment, replacing vItemsNotInMaster(k) = vCheckItems(i) with vArray3(k) = vCheckItems(i) will solve the problem.
But if you need learning arrays manipulation, the next more compact code returns the same in less code lines number:
Public Sub Testing_()
Dim myArray1(1 To 4) As String
Dim myArray2(1 To 4) As String
Dim myArray3 As Variant
myArray1(1) = "one1"
myArray1(2) = "two2"
myArray1(3) = "three5"
myArray1(4) = "four7"
myArray2(1) = "one1"
myArray2(2) = "two3"
myArray2(3) = "different"
myArray2(4) = "four7"
myArray3 = Application.IfError(Application.match(myArray1, myArray2, 0), "x") 'it palces "x" when not a match...
Debug.Print Join(myArray3, "|") 'just to visually see the return...
'for a single case:
Debug.Print "(first) missing element: " & myArray1(Application.match("x", myArray3, 0)) 'it returns according to the first occurrence
'For more than one missing occurrence:
Dim i As Long
For i = 1 To UBound(myArray3)
If myArray3(i) = "x" Then
Debug.Print "Missing: " & myArray1(i)
End If
Next i
End Sub
To return occurrences independent of array elements position, it is also simpler to use Application.Match (with a single iteration). If interested, I can also post such a function...
As pointed out by #FunThomas the function does not return anything. Fix for type mismatch error is to Redim the vItemsNotInMaster array for each new item, while preserving the already populated values.
The vArray3 variable does not make sense and function should be rewritten as:
Public Function Comparing_TwoArrays(ByVal vCheckItems As Variant, ByVal vMasterList As Variant) As Variant
Dim vItemsNotInMaster()
Dim isMatch As Boolean
Dim i As Integer
Dim j As Integer
Dim k As Integer
k = 1
For i = LBound(vCheckItems, 1) To UBound(vCheckItems, 1)
isMatch = False
For j = LBound(vMasterList, 1) To UBound(vMasterList, 1)
If vCheckItems(i) = vMasterList(j) Then
isMatch = True
Exit For
End If
Next j
If (isMatch = False) Then
ReDim Preserve vItemsNotInMaster(1 To k)
vItemsNotInMaster(k) = vCheckItems(i) '---> Throws type mismatch
k = k + 1
End If
Next i
Comparing_TwoArrays = vItemsNotInMaster
End Function
Return Matching Array Elements
The function will return an array of the not matching elements from the check array in the master array.
If all elements are matching (are found in master), it will return an array whose upper limit is less than its lower limit.
Option Explicit
Public Sub Testing()
Dim myArray1(1 To 4) As Variant
Dim myArray2(1 To 4) As Variant
Dim myArray3 As Variant
myArray1(1) = "one1"
myArray1(2) = "two3"
myArray1(3) = "three5"
myArray1(4) = "four7"
myArray2(1) = "one1"
myArray2(2) = "two3"
myArray2(3) = "different"
myArray2(4) = "four7"
myArray3 = NotInMasterArray(myArray1, myArray2)
If LBound(myArray3) <= UBound(myArray3) Then
' Column
Debug.Print "Column" & vbLf & Join(myArray3, vbLf)
' Delimited row:
Debug.Print "Row" & vbLf & Join(myArray3, ",")
Else
Debug.Print "All elements from Check array found in Master array."
End If
Stop
End Sub
Public Function NotInMasterArray( _
arrCheck() As Variant, _
arrMaster() As Variant, _
Optional ByVal ResultLowerLimit As Variant) _
As Variant()
' Write the check array's limits to variables.
Dim cLB As Variant: cLB = LBound(arrCheck)
Dim cUB As Long: cUB = UBound(arrCheck)
' Determine the lower limit ('nLB') of the result array.
Dim nLB As Long
If IsMissing(ResultLowerLimit) Then ' use the check array's lower limit
nLB = cLB
Else ' use the given lower limit
nLB = ResultLowerLimit
End If
' Calculate the result array's upper limit.
Dim nUB As Long: nUB = cUB - cLB + nLB
' Define the initial result array ('arrNot') making it the same size
' as the check array (it is possibly too big; it is only of the correct size,
' if all check array's elements are not found in the master array).
Dim arrNot() As Variant: ReDim arrNot(nLB To nUB)
' Write the result array's lower limit decreased by 1 to the result
' array's limit counter variable (to first count and then write).
Dim n As Long: n = nLB - 1
Dim c As Long ' Check Array Limit Counter
' Loop through the elements of the check array.
For c = cLB To cUB
' Check if the current element is not found in the master array.
If IsError(Application.Match(arrCheck(c), arrMaster, 0)) Then
n = n + 1 ' count
arrNot(n) = arrCheck(c) ' write
'Else ' found in master; do nothing
End If
Next c
If n < nLB Then ' all found in master
arrNot = Array() ' i.e. UBound(arrNot) < LBound(arrNot)
Else ' not all are found in master
If n < nUB Then ' not all elements are not found...
ReDim Preserve arrNot(nLB To n) ' ... resize to 'n'
'Else ' all elements are not found; do nothing
End If
End If
' Assign the result array to the result of the function.
NotInMasterArray = arrNot
End Function
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
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
I'm looking for a little guidance and experience. I have an VBA module that creates two strings. See below. I want to use an array to compare the two stings and write the successful matches or "no match" for the element to a third array or directly to the worksheet.
The second part of this is a "percent of" match of Arr2 to Arr1. So the below example would be 88%.
> Arr1 result
> 726741,439037,X41033X,X0254XX,X47083X,X0252XX,X50047X,XH5815X
> Arr2 result
> 726742,439037,X41033X,X0254XX,X47083X,X0252XX,X50047X,XH5815X
Any advice would be great.
Here is one way to accomplish the task using simple for loops.
Sub compareStrings()
Dim str1 As String
Dim str2 As String
str1 = "726741,439037,X41033X,X0254XX,X47083X,X0252XX,X50047X,XH5815X"
str2 = "726742,439037,X41033X,X0254XX,X47083X,X0252XX,X50047X,XH5815X"
Dim Arr1 As Variant
Dim Arr2 As Variant
Dim ArrResults As Variant
Arr1 = Split(str1, ",")
Arr2 = Split(str2, ",")
Dim countMatches As Integer
countMatches = 0
ReDim ArrResults(UBound(Arr1))
For i = LBound(Arr1) To UBound(Arr1)
If Arr1(i) = Arr2(i) Then
ArrResults(i) = "Matches"
countMatches = countMatches + 1
Else
ArrResults(i) = "No Match"
End If
Next i
'Print out the results array in debug window
For Each entry In ArrResults
Debug.Print entry
Next entry
Dim ratio As Double
ratio = countMatches / (UBound(Arr1) + 1)
MsgBox (ratio * 100 & "%")
End Sub
Message box will display this:
Immediate window will display the results array values like this:
Try this:
Sub Test()
Dim str1 As String, str2 As String
Dim arr, i As Long, cnt As Long
str1 = "726741,439037,X41033X,X0254XX,X47083X,X0252XX,X50047X,XH5815X"
str2 = "726742,439037,X41033X,X0254XX,X47083X,X0252XX,X50047X,XH5815X"
For i = LBound(Split(str1, ",")) To UBound(Split(str1, ","))
If Not IsArray(arr) Then
arr = Array(IIf(Split(str1, ",")(i) = _
Split(str2, ",")(i), "Match", "NoMatch"))
Else
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = IIf(Split(str1, ",")(i) = _
Split(str2, ",")(i), "Match", "NoMatch")
End If
Next
'~~> Check the array
For i = LBound(arr) To UBound(arr)
Debug.Print arr(i)
If arr(i) = "Match" Then cnt = cnt + 1
Next
'~~> output the percentage
MsgBox Format(cnt / (UBound(arr) + 1), "0.00%")
End Sub
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