I'm trying to return a string array from a function to another array and i just cant seem to get it working. Any advice?
the call is :
labelTypes() = loadLabelCSV(runningPath)
the code :
Function loadLabelCSV(runpath As String) As String()
Dim arr(5, 0) As String
Dim x As Integer
Dim line As String
Dim lineArr() As String
Dim reader As New StreamReader(runpath & "\labelTypes.csv", Encoding.Default)
If System.IO.File.Exists(runpath & "\labelTypes.csv") = False Then
MsgBox("The label types file is missing please check.", vbCritical)
End If
Do
line = reader.ReadLine
If line = "" Then Exit Do
lineArr = Split(reader.ReadLine, ",")
For y = 0 To 5
arr(y, x) = lineArr(y)
Next
x = x + 1
ReDim Preserve arr(5, UBound(arr, 2) + 1)
Loop
Return arr
End Function
I have a loop, and I want to put the result into array.
Here is my loop.
For i = 1 To bill
a = rs("CT08_Tarikh") 'from db
cutiumum = Array(a) 'and this is how I declare array
rs.MoveNext
Next
rs.Close
Set rs = Nothing
End If
and after that, i will pass the variable to another function:
tarikh = NetWorkdays(dateFrom, dateTo, cutiumum)
Public Function NetWorkdays(dtStartDate, dtEndDate, arrHolidays)
but, when I try to do some loop for arrHolidays inside the function NetWorkdays, it only return 1 data (not all from the cutiumum).
What do you think is my mistake?
Update
I'm already using
dim arrRecordset
arrRecordset = rs.GetRows()
but I got an error inside the function
Public Function NetWorkdays(dtStartDate, dtEndDate, arrHolidays)
Dim lngDays
Dim lngSaturdays
Dim lngSundays
Dim lngHolidays
Dim lngAdjustment
Dim dtTest
Dim i, x
lngDays = DateDiff("d", dtStartDate, dtEndDate)
lngSundays = DateDiff("ww", dtStartDate, dtEndDate, vbSunday)
lngSaturdays = DateDiff("w", IIf(Weekday(dtStartDate, vbSunday) = vbSaturday, dtStartDate, dtStartDate - Weekday(dtStartDate, vbSunday)), dtEndDate)
For x = LBound(arrHolidays) To UBound(arrHolidays)
For i = 0 To lngDays
dtTest = DateAdd("d", i, dtStartDate)
'error in line here: Subscript out of range: 'arrHolidays'
If arrHolidays(x) = dtTest And Weekday(dtTest) <> 1 And Weekday(dtTest) <> 7 Then
lngHolidays = lngHolidays + 1
End If
Next
Next
If Weekday(dtStartDate, vbSunday) = vbSunday Or Weekday(dtStartDate, vbSunday) = vbSaturday Then
lngAdjustment = 0
Else
lngAdjustment = 1
End If
NetWorkdays = lngDays - lngSundays - lngSaturdays - lngHolidays + lngAdjustment
End Function
Try this:
dim arrRecordset
arrRecordset = rs.GetRows()
The getRows() method will transform a recordset into a two dimensional array in one go:
https://www.w3schools.com/asp/met_rs_getrows.asp
I need a public function to get array and counts values in specific column.
I wrote the following and recives subscription out of range message.
Public Function CountUarrcol(inarr() As Variant, colidx As Integer) As Long
Dim col As New Collection
Dim i As Integer
Dim element As Variant
For i = 0 To UBound(inarr, colidx)
For Each element In inarr(i + 1, colidx)
col.Add Item:=CStr(element.value), Key:=CStr(element.value)
Next
Next i
CountUarrcol = col.Count End Function
Assuming you want to do a count of distinct values within a specified column of an array, here is an example with a 5*3 array read in from a worksheet range, counting the distinct values in column 2. I am using a function by Mark Nold to check if the value to be added already exists in the collection.
Option Explicit
Public Sub test()
Dim testArr()
Dim myCount As Long
testArr = ActiveSheet.Range("A1:C5").Value
myCount = CountUarrcol(testArr, 2)
MsgBox myCount
End Sub
Public Function CountUarrcol(inarr() As Variant, colidx As Long) As Long
Dim col As New Collection
Dim i As Long
For i = 1 To UBound(inarr)
If Not InCollection(col, CStr(inarr(i, colidx))) Then
col.Add Item:=CStr(inarr(i, colidx)), key:=CStr(inarr(i, colidx))
End If
Next i
CountUarrcol = col.Count
End Function
'Mark Nold https://stackoverflow.com/questions/137845/determining-whether-an-object-is-a-member-of-a-collection-in-vba
Public Function InCollection(col As Collection, key As String) As Boolean
Dim var As Variant
Dim errNumber As Long
InCollection = False
Set var = Nothing
Err.Clear
On Error Resume Next
var = col.Item(key)
errNumber = CLng(Err.Number)
On Error GoTo 0
'5 is not in, 0 and 438 represent incollection
If errNumber = 5 Then ' it is 5 if not in collection
InCollection = False
Else
InCollection = True
End If
End Function
I Used two sub routine as follow:
Public Function CountUvalinarrcol(ByRef inarr As Variant, ByVal colidx As Integer) As Long
Dim col As New Collection
Dim i As Integer
Dim element As Variant
For i = 1 To UBound(inarr)
element = inarr(i, colidx)
If colContains(col, element) = False Then
col.Add item:=CStr(element)
End If
Next i
CountUvalinarrcol = col.Count
End Function
The other one is:
Public Function colContains(colin As Collection, itemin As Variant) As Boolean
Dim item As Variant
colContains = False
For Each item In colin
If item = itemin Then
colContains = True
Exit Function
End If
Next
End Function
Calling above functions:
sub test()
dim x as long
x= CountUvalinarrcol(lsarr, 0)
end sub
I am working in a function that will read a range of cells in one spreadsheet and write it on another spreadsheet.
To do that, I'm reading all of the cells from a source and target spreadsheet and then writing to an array to compare if there is already the value on the target spreadsheet
The point here, is that I can save the the values inside of the Array, but my functions are returning an empty array. Following are my code snippet.
Private Sub UpdateBacklog_Click()
Dim ArrSource() As String
Dim ArrTarget() As String
sourceRead Wks, ArrSource
targetRead Cwks, ArrTarget
End Sub
Function targetRead(targetWks, arrayT() As String)
.
.
rowCount = targetWks.Cells(Rows.Count, C_TRG_ID_COL).End(xlUp).Row
currentRow = C_TRG_ROW
id = 1
ReDim arrayT(1, 1)
If currentRow <= rowCount Then
For currentRow = currentRow To rowCount
ReDim arrayT(id, 1)
arrayT(id, 1) = targetWks.Cells(currentRow, C_TRG_ID_COL).Value
id = id + 1
DoEvents
Next
End If
End Function
Function sourceRead(sourceWks, arrayS() As String)
.
.
rowCount = sourceWks.Cells(Rows.Count, C_SRC_ID_COL).End(xlUp).Row
currentRow = C_SRC_ROW
id = 1
If currentRow <= rowCount Then
For currentRow = currentRow To rowCount
sourceStatus = sourceWks.Cells(currentRow, C_SRC_STS_COL).Value
ReDim arrayS(id, 1 To 4)
arrayS(id, 1) = sourceWks.Cells(currentRow, C_SRC_ID_COL).Value
arrayS(id, 2) = sourceWks.Cells(currentRow, C_SRC_DSC_COL).Value
arrayS(id, 3) = sourceWks.Cells(currentRow, C_SRC_PRC_COL).Value
arrayS(id, 4) = sourceStatus
id = id + 1
DoEvents
Next
End If
End Function
Try returning the arrays from the functions.
Private Sub UpdateBacklog_Click()
Dim ArrSource() As String
Dim ArrTarget() As String
ArrSource = sourceRead(Wks, ArrSource)
ArrTarget = targetRead(Cwks, ArrTarget)
End Sub
Function targetRead(targetWks, arrayT() As String)
' lots of stuff here
targetRead = arrayT
End Function
Function sourceRead(sourceWks, arrayS() As String)
' lots of stuff here
sourceRead = arrayS
End Function
You were treating the functions like subs that would change the byRef parameter that was being passed into them. A function is meant to return a value so assign the altered array(s) back into themselves. For all intents and purposes, this is no different than replacing the periods in a string with commas in something like,
tmp = replace(tmp, chr(46), chr(44))
I have an array prLst that is a list of integers. The integers are not sorted, because their position in the array represents a particular column on a spreadsheet. I want to know how I find a particular integer in the array, and return its index.
There does not seem to be any resource on showing me how without turning the array into a range on the worksheet. This seems a bit complicated. Is this just not possible with VBA?
Dim pos, arr, val
arr=Array(1,2,4,5)
val = 4
pos=Application.Match(val, arr, False)
if not iserror(pos) then
Msgbox val & " is at position " & pos
else
Msgbox val & " not found!"
end if
Updated to show using Match (with .Index) to find a value in a dimension of a two-dimensional array:
Dim arr(1 To 10, 1 To 2)
Dim x
For x = 1 To 10
arr(x, 1) = x
arr(x, 2) = 11 - x
Next x
Debug.Print Application.Match(3, Application.Index(arr, 0, 1), 0)
Debug.Print Application.Match(3, Application.Index(arr, 0, 2), 0)
EDIT: it's worth illustrating here what #ARich pointed out in the comments - that using Index() to slice an array has horrible performance if you're doing it in a loop.
In testing (code below) the Index() approach is almost 2000-fold slower than using a nested loop.
Sub PerfTest()
Const VAL_TO_FIND As String = "R1800:C8"
Dim a(1 To 2000, 1 To 10)
Dim r As Long, c As Long, t
For r = 1 To 2000
For c = 1 To 10
a(r, c) = "R" & r & ":C" & c
Next c
Next r
t = Timer
Debug.Print FindLoop(a, VAL_TO_FIND), Timer - t
' >> 0.00781 sec
t = Timer
Debug.Print FindIndex(a, VAL_TO_FIND), Timer - t
' >> 14.18 sec
End Sub
Function FindLoop(arr, val) As Boolean
Dim r As Long, c As Long
For r = 1 To UBound(arr, 1)
For c = 1 To UBound(arr, 2)
If arr(r, c) = val Then
FindLoop = True
Exit Function
End If
Next c
Next r
End Function
Function FindIndex(arr, val)
Dim r As Long
For r = 1 To UBound(arr, 1)
If Not IsError(Application.Match(val, Application.Index(arr, r, 0), 0)) Then
FindIndex = True
Exit Function
End If
Next r
End Function
array of variants:
Public Function GetIndex(ByRef iaList() As Variant, ByVal value As Variant) As Long
Dim i As Long
For i = LBound(iaList) To UBound(iaList)
If value = iaList(i) Then
GetIndex = i
Exit For
End If
Next i
End Function
a fastest version for integers (as pref tested below)
Public Function GetIndex(ByRef iaList() As Integer, ByVal value As Integer) As Integer
Dim i As Integer
For i = LBound(iaList) To UBound(iaList)
If iaList(i) = value Then: GetIndex = i: Exit For:
Next i
End Function
' a snippet, replace myList and myValue to your varible names: (also have not tested)
a snippet, lets test the assumption the passing by reference as argument means something. (the answer is no) to use it replace myList and myValue to your variable names:
Dim found As Integer, foundi As Integer ' put only once
found = -1
For foundi = LBound(myList) To UBound(myList):
If myList(foundi) = myValue Then
found = foundi: Exit For
End If
Next
result = found
to prove the point I have made some benchmarks
here are the results:
---------------------------
Milliseconds
---------------------------
result0: 5 ' just empty loop
result1: 2702 ' function variant array
result2: 1498 ' function integer array
result3: 2511 ' snippet variant array
result4: 1508 ' snippet integer array
result5: 58493 ' excel function Application.Match on variant array
result6: 136128 ' excel function Application.Match on integer array
---------------------------
OK
---------------------------
a module:
Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
#If VBA7 Then
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If
Public Function GetIndex1(ByRef iaList() As Variant, ByVal value As Variant) As Long
Dim i As Long
For i = LBound(iaList) To UBound(iaList)
If value = iaList(i) Then
GetIndex = i
Exit For
End If
Next i
End Function
'maybe a faster variant for integers
Public Function GetIndex2(ByRef iaList() As Integer, ByVal value As Integer) As Integer
Dim i As Integer
For i = LBound(iaList) To UBound(iaList)
If iaList(i) = value Then: GetIndex = i: Exit For:
Next i
End Function
' a snippet, replace myList and myValue to your varible names: (also have not tested)
Public Sub test1()
Dim i As Integer
For i = LBound(iaList) To UBound(iaList)
If iaList(i) = value Then: GetIndex = i: Exit For:
Next i
End Sub
Sub testTimer()
Dim myList(500) As Variant, myValue As Variant
Dim myList2(500) As Integer, myValue2 As Integer
Dim n
For n = 1 To 500
myList(n) = n
Next
For n = 1 To 500
myList2(n) = n
Next
myValue = 100
myValue2 = 100
Dim oPM
Set oPM = New PerformanceMonitor
Dim result0 As Long
Dim result1 As Long
Dim result2 As Long
Dim result3 As Long
Dim result4 As Long
Dim result5 As Long
Dim result6 As Long
Dim t As Long
Dim a As Long
a = 0
Dim i
't = GetTickCount
oPM.StartCounter
For i = 1 To 1000000
Next
result0 = oPM.TimeElapsed() ' GetTickCount - t
a = 0
't = GetTickCount
oPM.StartCounter
For i = 1 To 1000000
a = GetIndex1(myList, myValue)
Next
result1 = oPM.TimeElapsed()
'result1 = GetTickCount - t
a = 0
't = GetTickCount
oPM.StartCounter
For i = 1 To 1000000
a = GetIndex2(myList2, myValue2)
Next
result2 = oPM.TimeElapsed()
'result2 = GetTickCount - t
a = 0
't = GetTickCount
oPM.StartCounter
Dim found As Integer, foundi As Integer ' put only once
For i = 1 To 1000000
found = -1
For foundi = LBound(myList) To UBound(myList):
If myList(foundi) = myValue Then
found = foundi: Exit For
End If
Next
a = found
Next
result3 = oPM.TimeElapsed()
'result3 = GetTickCount - t
a = 0
't = GetTickCount
oPM.StartCounter
For i = 1 To 1000000
found = -1
For foundi = LBound(myList2) To UBound(myList2):
If myList2(foundi) = myValue2 Then
found = foundi: Exit For
End If
Next
a = found
Next
result4 = oPM.TimeElapsed()
'result4 = GetTickCount - t
a = 0
't = GetTickCount
oPM.StartCounter
For i = 1 To 1000000
a = pos = Application.Match(myValue, myList, False)
Next
result5 = oPM.TimeElapsed()
'result5 = GetTickCount - t
a = 0
't = GetTickCount
oPM.StartCounter
For i = 1 To 1000000
a = pos = Application.Match(myValue2, myList2, False)
Next
result6 = oPM.TimeElapsed()
'result6 = GetTickCount - t
MsgBox "result0: " & result0 & vbCrLf & "result1: " & result1 & vbCrLf & "result2: " & result2 & vbCrLf & "result3: " & result3 & vbCrLf & "result4: " & result4 & vbCrLf & "result5: " & result5 & vbCrLf & "result6: " & result6, , "Milliseconds"
End Sub
a class named PerformanceMonitor
Option Explicit
Private Type LARGE_INTEGER
lowpart As Long
highpart As Long
End Type
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long
Private m_CounterStart As LARGE_INTEGER
Private m_CounterEnd As LARGE_INTEGER
Private m_crFrequency As Double
Private Const TWO_32 = 4294967296# ' = 256# * 256# * 256# * 256#
Private Function LI2Double(LI As LARGE_INTEGER) As Double
Dim Low As Double
Low = LI.lowpart
If Low < 0 Then
Low = Low + TWO_32
End If
LI2Double = LI.highpart * TWO_32 + Low
End Function
Private Sub Class_Initialize()
Dim PerfFrequency As LARGE_INTEGER
QueryPerformanceFrequency PerfFrequency
m_crFrequency = LI2Double(PerfFrequency)
End Sub
Public Sub StartCounter()
QueryPerformanceCounter m_CounterStart
End Sub
Property Get TimeElapsed() As Double
Dim crStart As Double
Dim crStop As Double
QueryPerformanceCounter m_CounterEnd
crStart = LI2Double(m_CounterStart)
crStop = LI2Double(m_CounterEnd)
TimeElapsed = 1000# * (crStop - crStart) / m_crFrequency
End Property
Here's another way:
Option Explicit
' Just a little test stub.
Sub Tester()
Dim pList(500) As Integer
Dim i As Integer
For i = 0 To UBound(pList)
pList(i) = 500 - i
Next i
MsgBox "Value 18 is at array position " & FindInArray(pList, 18) & "."
MsgBox "Value 217 is at array position " & FindInArray(pList, 217) & "."
MsgBox "Value 1001 is at array position " & FindInArray(pList, 1001) & "."
End Sub
Function FindInArray(pList() As Integer, value As Integer)
Dim i As Integer
Dim FoundValueLocation As Integer
FoundValueLocation = -1
For i = 0 To UBound(pList)
If pList(i) = value Then
FoundValueLocation = i
Exit For
End If
Next i
FindInArray = FoundValueLocation
End Function
Is this what you are looking for?
public function GetIndex(byref iaList() as integer, byval iInteger as integer) as integer
dim i as integer
for i=lbound(ialist) to ubound(ialist)
if iInteger=ialist(i) then
GetIndex=i
exit for
end if
next i
end function
Taking care of whether the array starts at zero or one.
Also, when position 0 or 1 is returned by the function, making sure that the same is not confused as True or False returned by the function.
Function array_return_index(arr As Variant, val As Variant, Optional array_start_at_zero As Boolean = True) As Variant
Dim pos
pos = Application.Match(val, arr, False)
If Not IsError(pos) Then
If array_start_at_zero = True Then
pos = pos - 1
'initializing array at 0
End If
array_return_index = pos
Else
array_return_index = False
End If
End Function
Sub array_return_index_test()
Dim pos, arr, val
arr = Array(1, 2, 4, 5)
val = 1
'When array starts at zero
pos = array_return_index(arr, val)
If IsNumeric(pos) Then
MsgBox "Array starting at 0; Value found at : " & pos
Else
MsgBox "Not found"
End If
'When array starts at one
pos = array_return_index(arr, val, False)
If IsNumeric(pos) Then
MsgBox "Array starting at 1; Value found at : " & pos
Else
MsgBox "Not found"
End If
End Sub
'To return the position of an element within any-dimension array
'Returns 0 if the element is not in the array, and -1 if there is an error
Public Function posInArray(ByVal itemSearched As Variant, ByVal aArray As Variant) As Long
Dim pos As Long, item As Variant
posInArray = -1
If IsArray(aArray) Then
If not IsEmpty(aArray) Then
pos = 1
For Each item In aArray
If itemSearched = item Then
posInArray = pos
Exit Function
End If
pos = pos + 1
Next item
posInArray = 0
End If
End If
End Function
The only (& even though cumbersome but yet expedient / relatively quick) way I can do this, is to concatenate the any-dimensional array, and reduce it to 1 dimension, with "/[column number]//\|" as the delimiter.
& use a single-cell result multiple lookupall macro function on the this 1-d column.
& then index match to pull out the positions. (usuing multiple find match)
That way you get all matching occurrences of the element/string your looking for, in the original any-dimension array, and their positions. In one cell.
Wish I could write a macro / function for this entire process. It would save me more fuss.