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
Related
I would like to reuse vSheetNamesTemp array.
It's collecting sheets with q* but I want to use it for other sheets like w*.
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swDrawing = swModel
Dim vSheetNamesTemp As Variant
vSheetNamesTemp = swDrawing.GetSheetNames
removed = 0
For i = 0 To UBound(vSheetNamesTemp)
vSheetNamesTemp(i - removed) = vSheetNamesTemp(i)
SheetName = vSheetNamesTemp(i)
If Not SheetName Like "q*" Then
removed = removed + 1
End If
Next i
If (UBound(vSheetNamesTemp) - removed) >= 0 Then
ReDim Preserve vSheetNamesTemp(0 To (UBound(vSheetNamesTemp) - removed))
vSheetNames = vSheetNamesTemp
End If
End Sub
Try the next approach, please:
Create a variable on top of the module (declarations side):
Private vSheetNames As Variant
Copy your transformed Sub:
Sub main()
Dim arrCriteria As Variant, El As Variant
'Please, appropriately declare the used variables. I do not use Solidworks
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set swDrawing = swModel
vSheetNames = swDrawing.GetSheetNames
arrCriteria = Split("q*,w*,x*", ",") 'use here as many criteria you need
For Each El In arrCriteria
If UBound(vSheetNames) >= 0 Then
removeSh vSheetNames, El
End If
Next
End Sub
In the same module, copy the next function:
Private Function removeSh(vSheetNamesTemp As Variant, strCriteria As String)
Dim removed As Long, i As Long
removed = 0
For i = 0 To UBound(vSheetNamesTemp)
vSheetNamesTemp(i - removed) = vSheetNamesTemp(i)
If Not vSheetNamesTemp(i) Like strCriteria Then
removed = removed + 1
End If
Next i
If (UBound(vSheetNamesTemp) - removed) >= 0 Then
ReDim Preserve vSheetNamesTemp(0 To (UBound(vSheetNamesTemp) - removed))
vSheetNames = vSheetNamesTemp
End If
End Function
The code is not tested, but it should work, I think. Please test it and send some feedback.
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
I've searched through a few websites and have not had any success in finding a solution that fits my needs. I am using a function in VBScript to create two arrays, one based on a specified date range, and the other is a dynamic array based on the filenames at the location of interest. I then compare the values in the two arrays and remove the duplicates from the main array, and check to see which values are weekdays.
So far all of that works. The difficulty I am having is being able to pass the "RangeArr()" array outside of the function. See my working code below:
FindMissingReports(TestPath)
Function FindMissingReports(Path)
Dim FileName, File
Dim RangeArr()
intSize = 0
For i = 0 to 7
ReDim Preserve RangeArr(intSize)
RangeArr(intSize) = Year(Date - i) & "-" & Month(Date - i) & "-" & Day(Date - i)
intSize = intSize +1
Next
'
Dim FileArr()
intSize = 0
'
Set oFSO = CreateObject("Scripting.FileSystemObject")
'Create the object used to display popup boxes
Set objShell = WScript.CreateObject("WScript.Shell")
'Loop through all of the files in the "Path" directory.
For Each File in oFSO.getfolder(Path).Files
'If the file name contains "Defect Report"
If instr(File.Name, "Defect Report") <> 0 Then
Set objFile = oFSO.GetFile(File)
'Define the filename as a variable
FileName = File.Name
'Get the report date from the first 10 characters of the filename.
FileDate = Left(FileName, 10)
ReDim Preserve FileArr(intSize)
FileArr(intSize) = FileDate
intSize = intSize +1
End If
Next
'
For i = 0 to UBound(FileArr)
For j = 0 to UBound(RangeArr)
If UBound(RangeArr) > UBound(FileArr) and UBound(FileArr) <> -1 Then
On Error Resume Next
If FileArr(i) = RangeArr(j) Then
removalIndexFile = i
For x = removalIndexFile to UBound(FileArr) -1
FileArr(x) = FileArr(x+1)
Next
ReDim Preserve FileArr(UBound(FileArr)-1)
removalIndexRange = j
For x = removalIndexRange to UBound(RangeArr) -1
RangeArr(x) = RangeArr(x+1)
Next
ReDim Preserve RangeArr(UBound(RangeArr)-1)
End If
End If
Next
Next
'
For i = 0 to UBound(RangeArr)
If IsWeekday(RangeArr(i)) Then
MsgBox(RangeArr(i) & ". It worked! This is the only weekday report missing from the list.")
End If
Next
'
End Function
Function IsWeekday(theDate)
IsWeekday = Weekday(theDate,vbMonday) <= 5
End Function
The VBScript way to return something from a function is to assign that something to the function's name. Demo:
Option Explicit
' To return x from a function, assign x to the function's name
Function f(p)
Select Case p
Case "Array()"
f = Array("array via Array()")
Case "FuncLikeSplit()"
f = Split("func-returns-(dyn)-array")
Case "DimReDimAssign"
Dim tmp
ReDim tmp(0)
tmp(0) = "Dim-ReDim-Assign"
f = tmp
Case Else
WScript.Echo "Error!"
End Select
End Function
Dim a, p
' prove for each a: it's a dynamic array
For Each p In Split("Array() FuncLikeSplit() DimReDimAssign")
a = f(p)
WScript.Echo p, TypeName(a), UBound(a), a(0)
ReDim Preserve a(Ubound(a) + 1)
a(UBound(a)) = "grownup"
WScript.Echo UBound(a), a(UBound(a))
WScript.Echo "----------------"
Next
output:
cscript 47042147.vbs
Array() Variant() 0 array via Array()
1 grownup
----------------
FuncLikeSplit() Variant() 0 func-returns-(dyn)-array
1 grownup
----------------
DimReDimAssign Variant() 0 Dim-ReDim-Assign
1 grownup
----------------
So:
FindMissingReports = RangeArr
at the end of the function, and:
Dim a : a = FindMissingReports(TestPath)
at the top level.
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'm trying to write a program that will loop through cells of a specific column (assigned by the user), find new values in those cells and count how many times a specific value is found. The main problem I'm having right now is that this is hard-coded like below:
Function findValues() As Long
For iRow = 2 To g_totalRow
If (ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text = "") Then
nullInt = nullInt + 1
ElseIf (someValue1 = "" Or someValue1 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue1 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt1 = someInt1 + 1
ElseIf (someValue2 = "" Or someValue2 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue2 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt2 = someInt2 + 1
ElseIf (someValue3 = "" Or someValue3 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue3 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt3 = someInt3 + 1
ElseIf (someValue4 = "" Or someValue4 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue4 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt4 = someInt4 + 1
ElseIf (someValue5 = "" Or someValue5 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue5 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt5 = someInt5 + 1
ElseIf (someValue6 = "" Or someValue6 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue6 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt6 = someInt6 + 1
ElseIf (someValue7 = "" Or someValue7 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue7 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt7 = someInt7 + 1
ElseIf (someValue8 = "" Or someValue8 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue8 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt8 = someInt8 + 1
ElseIf (someValue9 = "" Or someValue9 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue9 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt9 = someInt9 + 1
ElseIf (someValue10 = "" Or someValue10 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue10 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt10 = someInt10 + 1
End If
Next iRow
End Function
Here, if the ActiveCell is blank then the nullInt will get incremented, if the ActiveCell has some value then it'll find which of the variables has that same value or the ActiveCell value will be assigned to one of the variables. I created ten variables strictly for testing purposes but I need to make up to one hundred. I was wondering if there was a way to complete this quickly. The only way I could think of was to create a String array and an Int array and store the values that way. However I'm not sure if this is the best way to get this done.
Edit
This portion is directed specifically to dictionaries. Say there is a specific column titled "State". This contains the 50 North American states. Some of these states are repeated and there is a total of 800 values in this column. How do I keep track of how many times (for example) Texas gets hit?
Thank you,
Jesse Smothermon
You should be able to do this with a Dictionary (see Does VBA have Dictionary Structure?)
This code hasn't been tested but should give you a start.
Function findValues() As Scripting.Dictionary
Dim cellValue
Dim dict As New Scripting.Dictionary
For iRow = 2 To g_totalRow
cellValue = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
If dict.Exists(cellValue) Then
dict.Item(cellValue) = dict.Item(cellValue) + 1
Else
dict.Item(cellValue) = 1
End If
Next iRow
Set findValues = dict
End Function
Sub displayValues(dict As Scripting.Dictionary)
Dim i
Dim value
Dim valueCount
For i = 1 To dict.count
valueCount = dict.Items(i)
value = dict.Keys(i)
ActiveWorkbook.Sheets(sheetName).Cells(i, 3).Text = value
ActiveWorkbook.Sheets(sheetName).Cells(i, 4).Text = valueCount
Next i
End Sub
Sub RunAndDisplay()
Dim dict
Set dict = findValues
displayValues dict
End Sub
I've drafted a code for you, hope it helps. I added comments to make each step clearer for you. I believe that simply setting the proper values in the 1st step might make it work for you.
Still, would worth to understand what the code does to help you in the future.
Hope it fits your needs!
Option Explicit
Sub compareValues()
Dim oSource As Excel.Range
Dim oColumn As Excel.Range
Dim oCell As Excel.Range
Dim sBookName As String
Dim sSheetCompare As String
Dim sSheetSource As String
Dim sUserCol As String
Dim sOutputCol As String
Dim sFirstCell As String
Dim vDicItem As Variant
Dim sKey As String
Dim iCount As Integer
Dim sOutput As String
Dim oDic As Scripting.Dictionary
'1st - Define your source for somevalues and for the data to be compared
sBookName = "Book1"
sSheetCompare = "Sheet1"
sSheetSource = "Sheet2"
sFirstCell = "A1"
sOutputCol = "C"
'2nd - Define the 'somevalues' origin value; other values will be taken
' from the rows below the original value (i.e., we'll take our
' somevalues starting from sSheetSource.sFirstCell and moving to the
' next row until the next row is empty
Set oSource = Workbooks(sBookName).Sheets(sSheetSource).Range(sFirstCell)
'3rd - Populate our dictionary with the values beggining in the sFirstCell
populateDic oSource, oDic
'At this stage, we have all somevalues in our dictionary; to check if the
' valuesare as expected, uncomment the code below, that will print into
' immediate window (ctrl+G) the values in the dictionary
For Each vDicItem In oDic
Debug.Print vDicItem
Next vDicItem
'4th - ask the user for the column he wants to use; Use single letters.
' E.g.: A
sUserCol = InputBox("Enter the column the data will be compared")
'5th - scan the column given by the user for the values in the dictionary
Set oColumn = Workbooks(sBookName).Sheets(sSheetCompare).Columns(sUserCol)
'6th - Now, we scan every cell in the column
For Each oCell In oColumn.Cells
sKey = oCell.Value
'7th - Test the special case when the cell is empty
If sKey = "" Then oDic("Empty") = oDic("Empty") + 1
'8th - Test if the key value exists in the dictionary; if so, add it
If oDic.Exists(sKey) Then oDic(sKey) = oDic(sKey) + 1
'9th - Added to exit the for when row reaches 1000.
If oCell.Row = 1000 Then Exit For
Next oCell
'10th - Now, we print back the counters we found, only for sample purposes
' From now on, is up to you how to use the dictionary :)
iCount = 1
Set oColumn = Workbooks(sBookName).Sheets(sSheetCompare).Columns(sOutputCol)
Set oCell = oColumn.Cells(1, 1)
For Each vDicItem In oDic
If oDic(vDicItem) > 0 Then
oCell.Value = vDicItem
oCell.Offset(0, 1).Value = oDic(vDicItem)
Set oCell = oCell.Offset(1, 0)
End If
Next vDicItem
End Sub
Sub populateDic(ByRef oSource As Excel.Range, _
ByRef oDic As Scripting.Dictionary)
'Ideally we'd test if it's created. Let's just set it for code simplicity
Set oDic = New Scripting.Dictionary
'Let's add an 'empty' counter for the empty cells
oDic.Add "Empty", 0
While Len(oSource.Value) > 0
'If the data is not added into somevalues dictionary of values, we add
If Not oDic.Exists(oSource.Value) Then oDic.Add CStr(oSource.Value), 0
'Move our cell to the next row
Set oSource = oSource.Offset(1, 0)
Wend
End Sub