In the below script the the function returns only the final value that is 6 as the return value. Can anybody help me to return the intermediate values also as 3,4,5,6.
Function test_array() As Variant
Dim test() As Integer
Dim i As Integer
For i = 0 To 3
ReDim Preserve test(i)
test(i) = 3 + i
test_array = test(i)
Next i
End Function
For having output as 3,4,5,6, you need to create a string array and you can use Join function for the desired output.
PFB for the code. I hope this will help.
Function test_array() As String
Dim test() As String
Dim i As Integer
For i = 0 To 3
ReDim Preserve test(i)
test(i) = 3 + i
Next i
test_array = Join(test, ",")
End Function
In order to return the whole array, you just need to modify your line test_array = test(i) to test_array = test , and put it outside the For loop. The reason for that is once test array is fully populated inside your For loop, you copy it contents to test_array, and return it to the calling procedure.
I added a short test Function procedure just to show that all the array results are returned to the calling procedure.
Function test_array Code
Function test_array() As Variant
Dim test() As Integer
Dim i As Integer
For i = 0 To 3
ReDim Preserve test(i)
test(i) = 3 + i
Next i
test_array = test
End Function
Sub Test_Func Code
Sub Test_Func()
Dim myArr() As Integer
Dim i As Integer
myArr = test_array
For i = LBound(myArr) To UBound(myArr)
MsgBox "Array element " & i & " value is " & myArr(i)
Next i
End Sub
Edit 1: return all the elements inside the array to the cell (as a String):
Function test_array() As String
Dim test() As Integer
Dim testStr As String
Dim i As Integer
For i = 0 To 3
ReDim Preserve test(i)
test(i) = 3 + i
If testStr = "" Then
testStr = test(i)
Else
testStr = testStr & "," & test(i)
End If
Next i
test_array = testStr
End Function
'Little modification to your code will return all value as comma separated value like "3,4,5,6" in a cell
Function test_array() As Variant
Dim test() As Integer
Dim i As Integer
Dim ret As String
For i = 0 To 3
ReDim Preserve test(i)
test(i) = 3 + i
ret = ret & "," & test(i)
Next i
test_array = ret
End Function
Sub test1()
Cells(1, 1) = test_array()
'This must produce string "3,4,5,6" in cell A1 of active excel sheet
End Sub
Related
I have a function that loads certain data from a dynamic table into an array. The function works fine, when I check the local window I get the correct data. Also when I call the data from a sub, everything seems to work fine till I write the array to a new sheet, then I only get the first record repeatedly.
This is my code:
Function LoadData() As String()
Dim rng2 As Range, intJaNein As Integer, rngZelle As Range, X As Integer, cntAnzahl As Integer
Dim strAusgabe() As String 'R?ckgabe Array
intJaNein = 1
X = 0
Set rng2 = Range("tblMaschinen[DisplayList]")
cntAnzahl = WorksheetFunction.CountIfs(rng, m_intListIndex, rng2, intJaNein)
ReDim strAusgabe(cntAnzahl)
For Each rngZelle In rng2.Cells
If rngZelle.Offset(, -2).value = 0 And _
rngZelle.value = 1 And _
X <= cntAnzahl Then
strAusgabe(X) = rngZelle.Offset(, -1).value
X = X + 1
End If
Next rngZelle
LoadData = strAusgabe
End Function
Sub Test()
Dim sht As Worksheet, rng As Range, arr() As String
If ThisWorkbook.Worksheets("Loeschen") Is Nothing Then
Set sht = ActiveWorkbook.Worksheets.Add
sht.Name = "Loeschen"
End If
Set rng = Range("A1:A19")
arr = cls.LoadData
rng.value = arr
End Sub
This is the locals output when getting to the last row of code (rng.value = arr)
And this is what appears in my worksheet.
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
I have 2 Subs, both receive array as argument. one works fine, the other gives: compile error: Type mismatch: array or user-defined type expected.
In the code written bellow, "InitializeArray" works and "PresentTotalRow" does not work.
Can anyone figure out why?
Sub PresentTotalRow(nCells As Integer, totalProductsPerDay() As Integer)
row = nCells + MatrixRowOffset + 2
Range(Cells(row, 2), Cells(row, 8)) = totalProductsPerDay
End Sub
Sub InitializeArray(ByRef arr() As Long)
Dim N As Long
For N = LBound(arr) To UBound(arr)
arr(N) = 0
Next N
End Sub
Sub ReadTxtFile()
.....
Dim totalProductsPerDay(0 To 6) As Long
InitializeArray totalProductsPerDay
Dim filePath As String
filePath = "C:\work\Documents\input.txt"
Dim oFS As TextStream
If oFSO.FileExists(filePath) Then
Set oFS = oFSO.OpenTextFile(filePath)
......
i = 1
Do While Not oFS.AtEndOfStream
line = oFS.ReadLine
....
nCells = calcNCells
totalProductsCounter = GetTotalProductsCounter()
totalProductsPerDay(Day) = totalProductsPerDay(Day) + totalProductsCounter
i = i + 1
Loop
PresentTotalRow nCells, totalProductsPerDay
oFS.Close
Else
MsgBox "The file path is invalid.", vbCritical, vbNullString
Exit Sub
End If
Exit Sub
End Sub
Thanks,
Li
Sub PresentTotalRow(nCells As Integer, totalProductsPerDay() As Integer)
row = nCells + MatrixRowOffset + 2
Range(Cells(row, 2), Cells(row, 8)) = totalProductsPerDay
End Sub
the second argument expects an integer array
PresentTotalRow nCells, totalProductsPerDay
you are passing an long array here as the second argument
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