VBA Excel - Passing Array is not updating the reference - arrays

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))

Related

Change a single-dimension array into a multi-dimensional array in VBA for Access

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

get array into new sheet?

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.

VBA function returning '#VALUE!'

Public Function MostOccuring(items() As Variant) As String
Dim count() As Integer
Dim strings() As Object
Dim Index As Integer
For Index = 0 To items.Length - 1
If srings.Exists(items(Index)) Then
count(strings.IndexOf(items(Index))) = 1 + count(strings.IndexOf(items(Index)))
Else
count(Index) = 1
strings(Index) = items(Index)
End If
Next
End
MostOccuring = strings(count.IndexOf(count.Max()))
End Function
This is my mostocurring function
This is how I call it
And it return '#VALUE!'. Why? It should return the most occuring string of the cells. Thanks.
You may also try something like this...
Public Function MostOccuring(items As Range) As String
Dim cell As Range
Dim dict, it
Dim maxCnt As Long
Set dict = CreateObject("Scripting.Dictionary")
For Each cell In items
If Not dict.exists(cell.Value) Then
dict.Item(cell.Value) = 1
Else
dict.Item(cell.Value) = dict.Item(cell.Value) + 1
End If
Next cell
For Each it In dict.keys
If dict.Item(it) > maxCnt Then
maxCnt = dict.Item(it)
MostOccuring = it
End If
Next it
End Function

How to store loop result into array in VBScript?

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

Redimming arrays in VBA

I have 3 arrays of data, that are filled by reading off of an excel sheet, some of the points of data are missing and as such have just been entered into excel as "NA" so I want to look through my array and find each instance of these NA's and remove them from the array since the information is useless. I need to update all three arrays at the same time.
Sub group_data()
Dim country(), roe(), iCap() As String
Dim i As Integer
For i = 1 To 3357
country(i) = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("C1").Offset(i, 0)
roe(i) = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("AP1").Offset(i, 0)
iCap(i) = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("BM1").Offset(i, 0)
Next i
End Sub
So if I find a "NA" as one of the values in roe or iCap I want to get rid of that piece of data in all there arrays.
Note: I have written this code in Notepad.
Let me know if you face any problem with this.
Sub group_data()
dim totalRows as integer
dim rowNum as integer
dim rowsWithoutNA as integer
dim c1Range as Range
dim ap1Range as Range
dim bm1Range as Range
set c1Range = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("C1")
set ap1Range = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("AP1")
set bm1Range = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("BM1")
Dim country(), roe(), iCap() As String
Dim i As Integer
totalRows = 3357
redim country(totalRows)
redim roe(totalRows)
redim iCap(totalRows)
For i = 0 To (totalRows - 1)
rowNum = rowNum + 1
roe(rowsWithoutNA) = ap1Range.Offset(rowNum, 0).Text
iCap(rowsWithoutNA) = bm1Range.Offset(rowNum, 0).Text
if (WorksheetFunction.IsNA(roe(rowNum)) _
OR WorksheetFunction.IsNA(iCap(rowNum))) = False Then
' use the following condition, if NA is written in text
'if (trim(roe(rowNum)) = "NA" OR trim(iCap(rowNum)) = "NA") Then
country(rowsWithoutNA) = c1Range.Offset(rowNum, 0)
rowsWithoutNA = rowsWithoutNA + 1
end if
Next i
redim preserve country(rowsWithoutNA )
redim preserve roe(rowsWithoutNA )
redim preserve iCap(rowsWithoutNA )
end sub
I wouldn't even include the "NA" in the first place when building the arrays. Here's your code, but changed to not include "NA".
Sub group_data()
Dim country() As String
ReDim country(0)
Dim roe() As String
ReDim roe(0)
Dim iCap() As String
ReDim iCap(0)
Dim i As Integer
Dim increment1, increment2, increment3 As Integer
increment1 = 0
increment2 = 0
increment3 = 0
For i = 1 To 3357
If Not Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("C1").Offset(i, 0) = "NA" Then
ReDim Preserve country(UBound(country) + 1)
country(increment1) = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("C1").Offset(i, 0)
increment1 = increment1 + 1
End If
If Not Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("AP1").Offset(i, 0) = "NA" Then
ReDim Preserve roe(UBound(roe) + 1)
roe(increment2) = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("AP1").Offset(i, 0)
increment2 = increment2 + 1
End If
If Not Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("BM1").Offset(i, 0) = "NA" Then
ReDim Preserve iCap(UBound(iCap) + 1)
iCap(increment3) = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("BM1").Offset(i, 0)
increment3 = increment3 + 1
End If
Next i
End Sub
Just to be clear, I am assuming you have a list of countries in Range C1 and then associated roe and iCap values in ranges AP1 and BM1. The issue that some of the roe and iCap entires are missing and have been entered as 'NA'. You would like to create arrays that contain only countries where there is both an roe and iCap value.
Firstly, using Redim Preserve is an 'expensive' operation and will impact efficiency of code.
Secondly, as an aside, using syntax as in your code (below) will only set the final variable to String. The first two will be created as variable type Variant:
Dim country(), roe(), iCap() As String
This code should be written as:
Dim country() as String, roe() as String, iCap() As String
In terms of your issue, my approach would be as follows:
Sub FillArrays()
'Define arrays
Dim countryArray() As String, roeArray() As Variant, iCapArray() As Variant
'Get total number of countries
Dim totalRows As Long
totalRows = Workbooks("restcompfirm.xls").Worksheets("Sheet1").Range("C1").End(xlDown).Row
'Define array size based on totalRows
ReDim countryArray(totalRows - 1)
ReDim roeArray(totalRows - 1)
ReDim iCapArray(totalRows - 1)
'Define missing data text
Dim missingData As String
missingData = "NA"
Dim iArray As Long
iArray = 0
With Workbooks("restcompfirm.xls").Worksheets("Sheet1")
'Loop through each row and check if either roe or iCap are set to 'NA'
For cl = 1 To totalRows
If Trim(.Range("AP" & cl)) <> missingData Then
If Trim(.Range("BM" & cl)) <> missingData Then
countryArray(iArray) = .Range("C" & cl)
roeArray(iArray) = .Range("AP" & cl)
iCapArray(iArray) = .Range("BM" & cl)
iArray = iArray + 1
End If
End If
Next cl
End With
End Sub
Hope this helps.

Resources