I am unable to iterate completely through an excel VBA Collection of custom objects. I receive an Invalid procedure call or argument error on the third object.
When examining each object and stepping line-by-line through the procedure, it works on the first two objects, then fails on the third. I've tried executing the code alone, calling the third object instance manually, with no error.
Why would the procedure execute the calculation and set the first two object instance's property correctly, then fail the third time?
I'm new to VBA - what obvious thing am I missing?
The Procedure:
Sub calculateMaintenancePlan()
'Calculates next x maintenance cycles for a number aircraft
'Assumes the spreadsheet defines a named range containing the following columns:
'1 2 3 4 5 6
'Tail Number Current Hours Next Cycle Next Cycle DUE In Heavy Week Id Cycle Start
'6004 11265.0 4 11333.7 FALSE [Integer or -10 if not in heavy]
'debugging/utility variables
Dim temp As Variant
Dim i As Integer, j As Integer
'Assumes the spreadsheet defines a named range containing the following columns:
'Cycle ID Cycle Type Duration Text ID
'1 200 hour 1 HMT1
ReDim mx_cycles(1 To Worksheets("Matrix Inputs").Range("maintenance_cycles").Rows.Count, 1 To 3)
For i = 1 To Worksheets("Matrix Inputs").Range("maintenance_cycles").Rows.Count
mx_cycles(i, 1) = Worksheets("Matrix Inputs").Range("maintenance_cycles").Cells(i, 2)
mx_cycles(i, 2) = CInt(Worksheets("Matrix Inputs").Range("maintenance_cycles").Cells(i, 3))
mx_cycles(i, 3) = Worksheets("Matrix Inputs").Range("maintenance_cycles").Cells(i, 4)
'Debug.Print i & " : " & mx_cycles(i, 1) & " : " & mx_cycles(i, 2) & " : " & mx_cycles(i, 3)
Next i
'an array containing each aircraft tail number, assume spreadsheet
'contains named range called "aircraft"
Dim aircraft As Collection, s_Aircraft As Collection
Dim acft As c_Aircraft
Set aircraft = New Collection
Set s_Aircraft = New Collection
'Set the Collection size to the total number of aircraft on station
'and create a c_Aircraft instance representing each airframe
For i = 1 To Range("aircraft").Count
Set acft = New c_Aircraft
acft.init_aircraft Worksheets("Matrix Inputs").Range("inputs"), i, mx_cycles
aircraft.Add acft, CStr(acft.tailNumber)
Next i
'Sort the aircraft
Set s_Aircraft = sortedAircraft(aircraft)
End Sub
'Sort a Collection of c_aircraft objects
Private Function sortedAircraft(unsortedAircraft As Collection) As Collection
Set sortedAircraft = New Collection
Dim acft As c_Aircraft
Dim temp_acft As c_Aircraft
Dim i As Long, j As Long
Dim next_acft_cycle_start_week_id As Integer
Dim previous_acft As String
Dim t_tailNum
'copy the Collection to a new collection
For Each acft In unsortedAircraft
sortedAircraft.Add acft
Next acft
'Sort the aircraft
For i = 1 To sortedAircraft.Count
For j = i + 1 To sortedAircraft.Count
If sortedAircraft.Item(i).hoursToDUE > sortedAircraft.Item(j).hoursToDUE Then
Set temp_acft = sortedAircraft.Item(j)
sortedAircraft.Remove j
t_tailNum = CStr(temp_acft.tailNumber)
sortedAircraft.Add temp_acft, t_tailNum, i
End If
Next j
Next i
previous_acft = CStr(sortedAircraft.Item(1).tailNumber)
For Each acft In sortedAircraft
If acft.inHeavy = False Then
'******* FAILS here on the third item of six items in the collection
Debug.Print sortedAircraft.Item(previous_acft).weekIdCycleStart + sortedAircraft.Item(previous_acft).nextCycleDuration + 1
previous_acft = CStr(acft.tailNumber)
Else
previous_acft = CStr(acft.tailNumber)
End If
Next acft
End Function
The Object: Represents an aircraft with various properties
Option Explicit
'Class c_Aircraft
'Requires call to init_aircraft() with the Range and "row" of the aircraft instance to be created.
'Assumes the Range contains the following columns:
'1 2 3 4 5 6
'Tail Number Current Hours Next Cycle Next Cycle DUE In Heavy Week Id Cycle Start
'6004 11265.0 4 11333.7 FALSE 0
'Attributes
Private p_tailNumber As Long
Private p_tailNumStr As String
Private p_initialAircraftHours As Double
Private p_currentAircraftHours As Double
Private p_initialNextCycleType As Integer
Private p_nextCycleType As Integer
Private p_initialNextCycleDuration As Integer
Private p_nextCycleDuration As Integer
Private p_initialHoursNextCycleDue As Double
Private p_hoursNextCycleDue As Double
Private p_initialInHeavy As Boolean
Private p_inHeavy As Boolean
'An integer representing the Week Id the current cycle
'started, if in heavy maintenance
Private p_initialWeekIdCycleStart As Integer
Private p_weekIdCycleStart As Integer
Private p_initialHoursToDUE As Double
Private p_hoursToDUE As Double
Private p_initialHoursToDNE As Double
Private p_hoursToDNE As Double
'General Methods
'Custom Initialize
Public Sub init_aircraft(data_range As Range, asset_number As Integer, mxCycles() As Variant)
p_tailNumber = data_range(asset_number, 1)
p_tailNumStr = CStr(data_range(asset_number, 1))
p_initialAircraftHours = data_range(asset_number, 2)
p_currentAircraftHours = p_initialAircraftHours
p_initialNextCycleType = data_range(asset_number, 3)
p_nextCycleType = p_initialNextCycleType
p_initialNextCycleDuration = mxCycles(p_nextCycleType, 2)
p_nextCycleDuration = p_initialNextCycleDuration
p_initialHoursNextCycleDue = data_range(asset_number, 4)
p_hoursNextCycleDue = p_initialHoursNextCycleDue
p_initialInHeavy = data_range(asset_number, 5)
p_inHeavy = p_initialInHeavy
If p_inHeavy Then
p_initialWeekIdCycleStart = data_range(asset_number, 6)
p_weekIdCycleStart = p_initialWeekIdCycleStart
Else
'set to a week prior more than the longest cycle duration
p_initialWeekIdCycleStart = -10
p_weekIdCycleStart = -10
End If
p_initialHoursToDUE = Round(p_hoursNextCycleDue - p_currentAircraftHours, 1)
p_hoursToDUE = p_initialHoursToDUE
p_initialHoursToDNE = Round(p_hoursNextCycleDue - p_currentAircraftHours + 15, 1)
p_hoursToDNE = p_initialHoursToDNE
End Sub
'Return the aircraft objects properties as String
Public Function print_aircraft() As String
print_aircraft = p_tailNumber & vbCrLf & _
"Current Hours: " & p_currentAircraftHours & vbCrLf & _
"Next Cycle: " & p_nextCycleType & vbCrLf & _
"Next Cycle Duration: " & p_nextCycleDuration & vbCrLf & _
"Hours Next Cycle Due: " & p_hoursNextCycleDue & vbCrLf & _
"In Heavy: " & p_inHeavy & vbCrLf & _
"Week Id Cycle Start: " & p_weekIdCycleStart & vbCrLf & _
"DUE: " & p_hoursToDUE & vbCrLf & _
"DNE: " & p_hoursToDNE
End Function
'Get/Let Methods
' Hours Remaining to the DNE
Public Property Get hoursToDNE() As Double
hoursToDNE = p_hoursToDNE
End Property
Public Property Let hoursToDNE(HoursDNE As Double)
p_hoursToDNE = HoursDNE
End Property
'Hours Remaining to the DUE
Public Property Get hoursToDUE() As Double
hoursToDUE = p_hoursToDUE
End Property
Public Property Let hoursToDUE(HoursDUE As Double)
p_hoursToDUE = HoursDUE
End Property
' Aircraft in Heavy Property
Public Property Get inHeavy() As Boolean
inHeavy = p_inHeavy
End Property
Public Sub setInHeavy(Value As Boolean, weekIdCycleStarted As Integer)
p_inHeavy = Value
p_weekIdCycleStart = weekIdCycleStarted
End Sub
'p_weekIdCycleStart
Public Property Get weekIdCycleStart() As Integer
weekIdCycleStart = p_weekIdCycleStart
End Property
'p_weekIdCycleStart
Public Property Let weekIdCycleStart(weekId As Integer)
p_weekIdCycleStart = weekId
End Property
' Aircraft Hours at Next Maintenance Cycle Due Property
Public Property Get hoursNextCycleDue() As Double
hoursNextCycleDue = p_hoursNextCycleDue
End Property
Public Property Let hoursNextCycleDue(Value As Double)
p_hoursNextCycleDue = Value
End Property
' Next Maintenance Cycle Due Property
Public Property Get nextCycleType() As Integer
nextCycleType = p_nextCycleType
End Property
Public Property Let nextCycleType(cycleType As Integer)
p_nextCycleType = cycleType
End Property
' Next Maintenance Cycle Duration Property
Public Property Get nextCycleDuration() As Integer
nextCycleDuration = p_nextCycleDuration
End Property
Public Property Let nextCycleDuration(cycleDuration As Integer)
p_nextCycleDuration = cycleDuration
End Property
' Current Aircraft Hours Property
Public Property Get currentAircraftHours() As Double
currentAircraftHours = p_currentAircraftHours
End Property
Public Property Let currentAircraftHours(Value As Double)
p_currentAircraftHours = Value
End Property
' Tail Number Property
Public Property Get tailNumber() As Long
tailNumber = p_tailNumber
End Property
Public Property Let tailNumber(Value As Long)
p_tailNumber = Value
End Property
Related
Question
I have a shape in visio 2021 , which is the "GRID" found in "Charting Shapes"
I would like to scale the smaller shapes in the master according to the ratios. Therefore I would like to bind a new instance of the class I created below to my master, and then be able to resize the master, which intern would scale the components relative to the ratios.
Code
Class name = LWR_Calc
Private Widths() As Double
Private Heights() As Double
Private W, H As Double
Private TotalWidthRatio, TotalHeightRatio
Private WidthRatioSubDivision, HeightRatioSubDivision
Private Sub Class_Initialize()
W = 1
H = 1
End Sub
Public Sub SetWidths(Lst As String, Optional delimiter As String = ",")
Dim WidthsRatioStrArr() As String
Dim Current As Double
WidthsRatioStrArr = Split(Lst, delimiter)
TotalWidthRatio = 0
ReDim Widths(0 To UBound(WidthsRatioStrArr))
For i = 0 To UBound(WidthsRatioStrArr)
Current = CDbl(WidthsRatioStrArr(i))
Widths(i) = Current
TotalWidthRatio = TotalWidthRatio + Current
Next
WidthRatioSubDivision = W / TotalWidthRatio
End Sub
Public Sub SetHeights(Lst As String, Optional delimiter As String = ",")
Dim HeightsRatioStrArr() As String
Dim Current As Double
HeightsRatioStrArr = Split(Lst, delimiter)
TotalHeightRatio = 0
ReDim Heights(0 To UBound(HeightsRatioStrArr))
For i = 0 To UBound(HeightsRatioStrArr)
Current = CDbl(HeightsRatioStrArr(i))
Heights(i) = Current
TotalHeightRatio = TotalHeightRatio + Current
Next
HeightRatioSubDivision = H / TotalHeightRatio
End Sub
Public Function GetHeight(ByVal index As Integer) As Double
On Error GoTo endr:
GetHeight = Heights(index - 1) * HeightRatioSubDivision
Exit Function
endr:
GetHeight = 0
End Function
Public Function GetWidth(ByVal index As Integer) As Double
On Error GoTo endr:
GetWidth = Widths(index - 1) * WidthRatioSubDivision
Exit Function
endr:
GetWidth = 0
End Function
Public Property Let Width(ByVal vNewValue As Double)
W = vNewValue
End Property
Public Property Let Height(ByVal vNewValue As Double)
H = vNewValue
End Property
my sub which tests the code is as follows
Private Sub Test__LWR_Calc()
Dim LWRC As LWR_Calc
Set LWRC = New LWR_Calc
LWRC.Height = 2
LWRC.Width = 10
LWRC.SetWidths ("1.75,1,1,1,1,1,1,1,1,1")
LWRC.SetHeights ("1.75,1,1,1.75,1,1,1,1,1,1")
For i = 1 To 10
For j = 1 To 10
Debug.Print i & "-" & j & " "; LWRC.GetWidth(j) & " , " & LWRC.GetHeight(i)
Next
Next
Set LWRC = Nothing
End Sub
This code works to get the values below
Data
Output
The Outputs I Get vs the Output I Want.
I create a collection of custom class objects, I am able to retrieve all the object property except for amount property (which is an array)
the following is my code
Sub Ledger()
Dim ActPeriod As Long
Dim ForcastPeriod As Long
Dim sth As Worksheet
Dim Account As New ClsAccount
Dim allaccounts As New Collection
ActPeriod = 3
ForecastPeriod = 3
For i = 1 To Sheet1.Range("A4:A26").count
If Sheet1.Cells(i, 1) <> 0 Then
counter = counter + 1
Set Account = New ClsAccount
With Account
.Code = Sheet1.Cells(i, 1)
.Name = Sheet1.Cells(i, 2)
.amount = Sheet1.Range(Cells(i, 3), Cells(i, 2 + ActPeriod))
allaccounts.add Account, .Code
End With
End If
Next i
MsgBox allaccounts(3).amount(1, 1)
End Sub
the code I used to create the class is as follow
Private AccAmount As Variant
Private AccGrowth As Variant
Private AccName As String
Private AccCode As String
Property Let amount(amt As Variant)
AccAmount = amt
End Property
Property Get amount() As Variant
amount = AccAmount
End Property
Property Let Name(n As String)
AccName = n
End Property
Property Get Name() As String
Name = AccName
End Property
Property Let Code(c As String)
AccCode = c
End Property
Property Get Code() As String
Code = AccCode
End Property
I am getting this error
MsgBox allaccounts(3).amount()(1, 1)
Without the parentheses VBA thinks you're trying to pass 1, 1 to the Property Get procedure, and that's not defined with any parameters...
I am trying to write an Excel VBA function that will do two things. First, it will determine the number of movies in each genre and print it to the immediate window using the printMovieData function I have written. Secondly, it will return the genre that has the most number of movies using the FindMax function I have written. I have provided my codes for printMovieData, FindMax, and what I have so far for MoviesByGenre, however, I am not sure what I am doing wrong and am looking for help to get the function working. Currently, Excel is returning the #VALUE! error.
printMovieData:
Function printMovieData(title As String, arrayTopic, arrayOther)
printMovieData = ""
For i = 1 To UBound(arrayTopic)
Debug.Print arrayTopic(i) & " : " & arrayOther(i)
Next i
End Function
FindMax:
Function FindMax(valueArray, nameArray) As String
Dim i As Integer
Dim maxValue As Variant
maxValue = 0
For i = 1 To UBound(valueArray)
If valueArray(i) >= maxValue Then
maxValue = valueArray(i)
FindMax = nameArray(i)
End If
Next i
End Function
MoviesByGenre:
Function MoviesByGenre(genreRng As Range) As String
Dim i As Integer
Dim genreArray(1 To 4) As String
Dim countArray
genreArray(1) = Action
genreArray(2) = Comedy
genreArray(3) = Drama
genreArray(4) = Musical
For i = 1 To UBound(genreArray)
For j = 1 To genreRng.Count
If genreRng.Cells(j) = genreArray(i) Then
countArray(i) = countArray(i) + 1
End If
Next j
Next i
MoviesByGenre = printMovieData("Movies by Genre", genreArray, countArray)
MoviesByGenre = FindMax(countArray, genreArray)
End Function
TBH there are quite a lot of reasons why I wouldn't expect your code to work.
There are some assumptions made such as how you use genreRng.Count. This is assuming data to count is either one row or one column.
The following assumes that genreRng.Cells.Count, Ubound(genreArray) and UBound(countArray) are all the same. You don't ensure this.
There are missing variable declarations, no use of Option Explicit and a number of other things.
Overarching though, is that I think you want a different object to handle your count. This is where Collection and Scripting Dictionaries are very useful.
You can have the key as the genre and the count is held in the associated value. If the key already exists, i.e. a repeat genre, just add one to the existing count.
With that in mind, a starting point, might be something like (sorry, no error handling added):
Option Explicit
Public Sub test()
Dim genreCount As Object
Set genreCount = CreateObject("Scripting.Dictionary")
Set genreCount = MoviesByGenre(ActiveSheet.Range("A1:A3"), genreCount)
printMovieData "Movies by genre", genreCount
FindMax genreCount
End Sub
Public Function MoviesByGenre(ByRef genreRng As Range, ByVal genreCount As Object) As Object
Dim j As Long
For j = 1 To genreRng.Count 'assumes 1 column/row
Dim currentGenre As String
currentGenre = genreRng.Cells(j, 1)
If Not genreCount.Exists(currentGenre) Then
genreCount.Add currentGenre, 1
Else
genreCount(currentGenre) = genreCount(currentGenre) + 1
End If
Next j
Set MoviesByGenre = genreCount
End Function
Public Function printMovieData(ByVal title As String, ByVal genreCount As Object)
Dim key As Variant
Debug.Print title & vbCrLf 'put to next line
For Each key In genreCount.keys
Debug.Print key & " : " & genreCount(key)
Next key
End Function
Public Function FindMax(ByVal genreCount As Object) As String
Dim maxValue As Long
Dim maxGenre As String
Dim key As Variant
For Each key In genreCount.keys
If genreCount(key) > maxValue Then
maxValue = genreCount(key)
maxGenre = key
End If
Next key
Debug.Print vbNewLine & "Max genre is " & maxGenre & " with " & maxValue
End Function
Input and output:
Input:
Output:
I Have assigned Values for Each Variable of External Parameters but I'm unable to Call the Assigned Value through Loop.
The Code Which I'm using now is there for reference.
Thanks in Advance...
Module Module1
Public Int_Parameters() As String = {"Int_D1", _
"Int_D2", _
"Int_D3", _
"Int_D4"}
Public Ext_Parameters() As Integer= {"Ext_D1", _
"Ext_D2", _
"Ext_D3", _
"Ext_D4"}
Sub Assigning_Values()
Ext_D1 = 25
Ext_D2 = Ext_D1 + 25
Ext_D3 = Ext_D2 + 25
Ext_D4 = Ext_D3 + 25
End Sub
Sub Loop()
For Each Int_Parameter As String in Int_Parameters
For Each Ext_Parameter As String in Ext_Parameters
Int_Parameter = Ext_Parameter 'Ext_Parameter Value is 0 but i need the Assigned Values instead of 0
Next
Next
End Sub
End Module
Module Module1
Public Int_Parameters() As String = {"Int_D1", _
"Int_D2", _
"Int_D3", _
"Int_D4"}
Public Ext_D1, Ext_D2, Ext_D3, Ext_D4 As Integer
Public List1 As New ArrayList
Sub Assigning_Values()
Ext_D1 = 25
Ext_D2 = Ext_D1 + 25
Ext_D3 = Ext_D2 + 25
Ext_D4 = Ext_D3 + 25
Dim Ext_Parameters() As Integer= {"Ext_D1", _
"Ext_D2", _
"Ext_D3", _
"Ext_D4"}
For Each Ext_Parameter As Integer in Ext_Parameters
List1.Add(Ext_Parameter)
Next
End Sub
Sub Loop()
For Each Int_Parameter As String in Int_Parameters
For Each Ext_Parameter As Integer in Ext_Parameters
Int_Parameter = Ext_Parameter
Next
Next
End Sub
End Module
I get a compile error at the last line when testing the following: (Only public user defined types that are defined in a public object module can be coerced to or from a variant or passed to late-bound functions.)
Option Explicit
Public Type aType
P_Col As Integer
P_Rad As Single
P_X As Single
P_Y As Single
End Type
Function MakePatterns() As Variant
Dim i As Integer
Dim circles() As aType
For i = 1 To 5
ReDim Preserve circles(i)
circles(i).P_Col = Int(i / 2)
circles(i).P_Rad = i
circles(i).P_X = i * 10 + 1
circles(i).P_Y = i * 10 + 5
Next
For i = 1 To 5
Debug.Print circles(i).P_Col; circles(i).P_Rad; _
circles(i).P_X; circles(i).P_Y
Next
MakePatterns = circles
End Function
Is there a way to use TYPE and Function together to return an array? Or is there a more effective way?
In the code below Sub "TestCallFunction" calls the Function "MakePatterns", and after it prints the first array received back from the function in the Immediate window.
Option Explicit
Public Type aType
P_Col As Integer
P_Rad As Single
P_X As Single
P_Y As Single
End Type
Sub TestCallFunction()
Dim x() As aType
Dim i As Integer
x = MakePatterns
' print the first result received from Function MakePatterns
Debug.Print x(1).P_Col & ";" & x(1).P_Rad & ";" & x(1).P_X & ";" & x(1).P_Y
End Sub
Public Function MakePatterns() As aType()
Dim i As Integer
Dim circles() As aType
For i = 1 To 5
ReDim Preserve circles(i)
circles(i).P_Col = Int(i / 2)
circles(i).P_Rad = i
circles(i).P_X = i * 10 + 1
circles(i).P_Y = i * 10 + 5
Next
For i = 1 To 5
Debug.Print circles(i).P_Col; circles(i).P_Rad; _
circles(i).P_X; circles(i).P_Y
Next
MakePatterns = circles
End Function