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...
Related
I am trying to create a structure that I can use to separate individual elements of a record in order to use their components. Each record consists of a record number, group, division, category, and 5 integer codes that will be used for various operations depending on their group, division, and categories. Whenever I try to pass a RecordType into my ArrayList I get the error as stated in the title of this question. I have tried looking at other questions that have this error, but none of the answers seemed to work. I have tried creating a separate class for the RecordType, but it says it cant be done with a public class type. Here is the data I am trying to separate and use:
65f8|gh|l1|9k|985|8437|7894|9495|3730|
4287|gh|w1|uk|7341|5638|7715|8906|698|
3s89|jk|w1|h7|225|487|2013|4328|4066|
62l5|lo|r5|9k|5103|9879|3448|2921|7581|
486p|lo|r5|uk|6882|9879|2672|1015|3160|
a597|lo|r6|m9|385|6915|3615|9195|9817|
1m36|hu|k8|h7|656|8064|3852|9110|9858|
And this is the code I have written. The comments are loops I have used to test certain parts of the code in excel.
Type RecordType
number As String
group As String
div As String
cat As String
code1 As Integer
code2 As Integer
code3 As Integer
code4 As Integer
code5 As Integer
End Type
Sub ProgramOne()
Dim fileName As String, textData As String, fileLine As String, rowList() As String, numOfRecords As Integer, someString As String
Dim rowNum As Integer, colNum As Integer, counter As Integer, counter2 As Integer, groupCount As Integer, divCount As Integer, catCount As Integer
Dim groupBool As Boolean, catBool As Boolean, divBool As Boolean, groupList As Object, divList As Object, catList As Object
Set groupList = CreateObject("System.Collections.ArrayList")
Set divList = CreateObject("System.Collections.ArrayList")
Set catList = CreateObject("System.Collections.ArrayList")
fileName = "/Users/Ricky/Desktop/project1Data.txt"
Open fileName For Input As #1
rowNum = 1
Dim records As Object
Set records = CreateObject("System.Collections.ArrayList")
Dim placeholder As RecordType
Do Until EOF(1)
numOfRecords = numOfRecords + 1
Line Input #1, fileLine
rowList = Split(fileLine, "|")
placeholder.number = rowList(0)
placeholder.group = rowList(1)
placeholder.div = rowList(2)
placeholder.cat = rowList(3)
placeholder.code1 = rowList(4)
placeholder.code2 = rowList(5)
placeholder.code3 = rowList(6)
placeholder.code4 = rowList(7)
placeholder.code5 = rowList(8)
records.Add (placeholder)
Loop
'Dim counter2 As Integer
'counter2 = 2
' For x = 0 To UBound(records) - LBound(records)
' Cells(counter2, 1) = records(x).group
' Cells(counter2, 2) = records(x).div
' counter2 = counter2 + 1
' Next
Close #1
'For x = 0 To UBound(records) - LBound(records)
divBool = False
catBool = False
groupCount = 0
divCount = 0
catCount = 0
'Dim GroupName As Variant
'For Each GroupName In groupList
' groupBool = False
' For num = 0 To UBound(records) - LBound(records)
' If CStr(records(num).group) = CStr(GroupName) Then
' groupBool = True
' End If
' If Not groupBool Then
' groupCount = groupCount + 1
' groupList(groupCount) = records(num).group
' End If
' Next num
'Next GroupName
counter = 0
counter2 = 0
For Each GroupName In records
For Each GroupName2 In groupList
If records(counter).group = groupList(counter2) Then
groupBool = True
End If
counter2 = counter2 + 1
Next GroupName2
If groupBool = False Then
Next GroupName
Cells(1, 1) = "Number of records: " & numOfRecords
Cells(1, 2) = "Number of Groups: " & groupCount
Cells(2, 1) = "records index: " & UBound(records) - LBound(records)
counter = 0
'For Each GroupName In groupList
' Cells(3, counter) = GroupName
' counter = counter + 1
'Next GroupName
End Sub
Add a new class module, call it Record, move your Type in there, make it Private, and then declare a private field of that type, and expose a Property Get and a Property Let for each member:
Option Explicit
Private Type TRecord
Number As String
Group As String
Division As String
Category As String
Codes(1 To 5) As Long
End Type
Private this As TRecord
Public Property Get Number() As String
Number = this.Number
End Property
Public Property Let Number(ByVal value As String)
this.Number = value
End Property
Public Property Get Group() As String
Group = this.Group
End Property
Public Property Let Group(ByVal value As String)
this.Group = value
End Property
Public Property Get Division() As String
Division = this.Division
End Property
Public Property Let Division(ByVal value As String)
this.Division = value
End Property
Public Property Get Category() As String
Category = this.Category
End Property
Public Property Let Category(ByVal value As String)
this.Category = value
End Property
Public Property Get Code(ByVal index As Long) As Long
Code = this.Codes(index)
End Property
Public Property Let Code(ByVal index As Long, ByVal value As Long)
this.Codes(index) = value
End Property
Now use instances of that class instead, and it should work fine.
For additional cool-factor, remove+export the class module, open it in Notepad, and set its VB_PredeclaredId attribute to True. Save, and re-import the module: now your class has a default instance, and with that you can have a factory method:
Public Function Create(ByVal pNumber As String, ByVal pGroup As String, ByVal pDivision As String, ByVal pCategory As String, ParamArray pCodes As Variant) As Record
With New Record
.Number = pNumber
.Group = pGroup
.Division = pDivision
.Category = pCategory
'todo assert number of parameters to prevent out-of-bounds error
Dim i As Long
For i = LBound(pCodes) To UBound(pCodes)
.Code(i) = pCodes(i)
Next
Set Create = .Self
End with
End Function
Public Property Get Self() As Record
Set Self = Me
End Property
Now the reader loop can look like this:
Do Until EOF(1)
numOfRecords = numOfRecords + 1
Line Input #1, fileLine
rowList = Split(fileLine, "|")
records.Add Record.Create(rowList(0), rowList(1), rowList(2), rowList(3), rowList(4), rowList(5), rowList(6), rowList(7), rowList(8))
Loop
Note that a class' default instance can be abused to hold global state (e.g. like the way some people use UserForm's default instances). That doesn't mean they should. Use default instances for "static" methods that belong to the type rather than an instance, and you'll do great.
Combined with interfaces, you could even simulate immutability, but I don't think you need to go there for this.
Use a class, name it cRecord
Option Explicit
Private Type RecordType
number As String
group As String
div As String
cat As String
code1 As Integer
code2 As Integer
code3 As Integer
code4 As Integer
code5 As Integer
End Type
Dim mElement As RecordType
Property Let number(nval As String)
mElement.number = nval
End Property
Property Let group(nval As String)
mElement.group = nval
End Property
Property Let div(nval As String)
mElement.div = nval
End Property
Property Let cat(nval As String)
mElement.cat = nval
End Property
Property Let code1(nval As String)
mElement.code1 = nval
End Property
Property Let code2(nval As String)
mElement.code2 = nval
End Property
Property Let code3(nval As String)
mElement.code3 = nval
End Property
Property Let code4(nval As String)
mElement.code4 = nval
End Property
Property Let code5(nval As String)
mElement.code5 = nval
End Property
and then change your code to
Dim placeholder As cRecord
Do Until EOF(1)
numOfRecords = numOfRecords + 1
Line Input #1, fileLine
rowList = Split(fileLine, "|")
Set placeholder = New cRecord
placeholder.number = rowList(0)
placeholder.group = rowList(1)
placeholder.div = rowList(2)
placeholder.cat = rowList(3)
placeholder.code1 = rowList(4)
placeholder.code2 = rowList(5)
placeholder.code3 = rowList(6)
placeholder.code4 = rowList(7)
placeholder.code5 = rowList(8)
records.Add placeholder
Loop`
I get
error 438
when trying to add an element into a variant array. Can you help me debugging, pls ? Thx
Public Function CouponList() As Double
Dim nbCoupons_lg As Integer
Dim counter_lg As Integer
Dim coupons_var As Variant
Dim coupon As Cls_Coupon
nbCoupons_lg = Maturity_db * CouponPeriodicity_db
If (Not nbCoupons_lg = 0) Then
ReDim coupons_var(1 To nbCoupons_lg) As Variant
For counter_lg = 1 To nbCoupons_lg
Set coupon = New Cls_Coupon
coupon.Period_lg = counter_lg
coupon.Value_db = AnnualCouponRate_db * ParValue_db
coupon.PresentValue_db = coupon.Value_db / (1 + AnnualDiscountRate_db) ^ (coupon.Period_lg / Maturity_db)
coupons_var(counter_lg) = coupon
Next counter_lg
End If
CouponList = coupons_var
End Function
Imagine you have a class Party (like yours Coupon) like this:
Private m_lGuestsNumber As Long
Public Property Get GuestsNumber() As Long
GuestsNumber = m_lGuestsNumber
End Property
Public Property Let GuestsNumber(ByVal lNewValue As Long)
m_lGuestsNumber = lNewValue
End Property
If you want to have different objects of type Party, put into an array through a loop, this is a good way to do it:
Public Sub TestMe()
Dim myArr() As Variant
Dim cnt As Long
Dim additional As Long: additional = 10
Dim coupon As Party
ReDim myArr(1 To additional)
For cnt = 1 To additional
Set coupon = New Party
coupon.GuestsNumber = cnt * 2
Set myArr(cnt) = coupon
Next cnt
End Sub
Now you can easily exchange the above with your code. It should be working.
Maybe this question is simple, but I couldn't find an answer by googling.
So, I've got my class WSheet. I initialize array of objects of this class in my program:
ReDim WSheets(twb.Sheets.Count)
For i = 0 To UBound(WSheets)
Set WSheets(i) = New WSheet
Next i
And then, I try to read new values and sort them by insertion sort:
For i = twb.Sheets.Count To 2 Step -1
flag = False
tsName = twb.Sheets(i).Name
twb.Sheets(i).Delete
twb.Save
CurShW = curLen - FileLen(TempFName)
curLen = FileLen(TempFName)
For j = UBound(WSheets) To 2 Step -1
If WSheets(j - 1).Weight < CurShW Then
Set WSheets(j) = WSheets(j - 1)
Else
WSheets(j).SetName (tsName)
WSheets(j).SetWeight (CurShW)
flag = True
Exit For
End If
Next j
If Not flag Then
Set WSheets(1) = New WSheet
WSheets(1).SetName (tsName)
WSheets(1).SetWeight (CurShW)
flag = False
End If
Next i
So, the problem: after I set WSheets(j) = WSheets(j - 1), wsheets(j - 1) starts to contain link to wsheets(j), so, when I change wsheets(j), Wsheets (j - 1) changes too.
Please, share how to make absolute equation in this sample?
Thank you!
PS code in WSheet class
Dim SName As String 'Name of sheet
Dim SWeight As Long 'Weight of sheet in bytes
Dim blocks() As Long 'Weights of blocks in sheet in bytes
Public Function Weight() As Long
Weight = SWeight
End Function
Public Sub SetWeight(ByVal sw As Long)
SWeight = sw
End Sub
Public Function Name() As String
Name = SName
End Function
Public Sub SetName(ByVal nm As String)
SName = nm
End Sub
edited to turn the function into a Class method
You must clone the WSheet object instead of referencing it
For instance you could add a Clone() method to your WSheet class
Function Clone() As WSheet
Dim newWSheet As WSheet
Set newWSheet = New WSheet
newWSheet.SetName SName
newWSheet.SetWeight SWeight
Set Clone = newWSheet
End Function
Then in your main code change:
Set WSheets(j) = WSheets(j - 1)
To:
Set WSheets(j) = WSheets(j - 1).Clone
I had previously asked about how to evenly distribute the items in n lists into a single list and was referred to this question: Good algorithm for combining items from N lists into one with balanced distribution?.
I made a practical example of my solution for this in VBA for Excel, since my application for this was resorting my Spotify lists which can be easily pasted into Excel for manipulation. Assumptions are that you have a headerless worksheet (wsSource) of songs with columns A, B, C representing Artist, Song, SpotifyURI respectively, a "Totals" worksheet (wsTotals) containing the sum of songs for each Artist from wsSource sorted in descending order, and a "Destination" worksheet where the new list will be created. Could I get some suggestions to improve this? I was going to get rid of the totals worksheet and have this portion done in code, but I have to go and I wanted to go ahead and put this out there. Thanks!
Sub WeaveSort()
Dim wb As Workbook
Dim wsDest As Worksheet
Dim wsSource As Worksheet
Dim wsTotals As Worksheet
Dim i As Integer
Dim iLast As Integer
Dim iDest As Integer
Dim iSource As Integer
Dim iOldRow As Integer
Dim iNewRow As Integer
Dim dDiff As Double
Dim dDiffSum As Double
Set wb = ThisWorkbook
Set wsTotals = wb.Worksheets("Totals")
Set wsSource = wb.Worksheets("Source")
Set wsDest = wb.Worksheets("Dest")
iLast = wsTotals.Range("A1").End(xlDown).Row - 1
For i = 2 To iLast
iSource = wsTotals.Range("B" & i).Value
iDest = wsDest.Range("A99999").End(xlUp).Row
If i = 2 Then
wsDest.Range("A1:C" & iSource).Value2 = wsSource.Range("A1:C" & iSource).Value2
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
GoTo NextI
End If
dDiff = iDest / iSource
dDiffSum = 0
iNewRow = 0
For iOldRow = 1 To iSource
dDiff = iDest / iSource
dDiffSum = dDiffSum + dDiff
iNewRow = Round(dDiffSum, 0)
wsSource.Rows(iOldRow).Copy
wsDest.Rows(iNewRow).Insert xlShiftDown
iDest = iDest + 1
Next iOldRow
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
NextI:
Next i
End Sub
Great question! I would take an object oritentated approach. Also I didn;t think it was clear what the logic was so here is my answer. Two classes and one normal module. Save these separately with the filenames ListManager.cls, List.cls, tstListManager.bas
So the ListManager.cls is this
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ListManager"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private mdic As Object
Public Sub Initialise(ByVal vLists As Variant)
Set mdic = VBA.CreateObject("Scripting.Dictionary")
Dim vListLoop As Variant
For Each vListLoop In vLists
Dim oList As List
Set oList = New List
oList.Initialise vListLoop, ""
mdic.Add mdic.Count, oList
Next
End Sub
Public Function WeaveSort() As Variant
Dim dicReturn As Object
Set dicReturn = VBA.CreateObject("Scripting.Dictionary")
Dim oNextList As List
Set oNextList = Me.WhichListHasLeastProgress
While oNextList.PercentageDone <= 1
Dim vListItem As Variant
vListItem = oNextList.GetListItem
dicReturn.Add dicReturn.Count, vListItem
oNextList.MoveNext
Set oNextList = Me.WhichListHasLeastProgress
Wend
Dim vItems As Variant
vItems = dicReturn.Items
'I don't like this bit
ReDim vRet(1 To dicReturn.Count, 1 To 1)
Dim lLoop As Long
For lLoop = 0 To dicReturn.Count - 1
vRet(lLoop + 1, 1) = vItems(lLoop)
Next lLoop
WeaveSort = vRet
End Function
Public Function WhichListHasLeastProgress() As List
Dim vKeyLoop As Variant
Dim oListLoop As List
Dim oLeastProgress As List
For Each vKeyLoop In mdic.keys
Set oListLoop = mdic.Item(vKeyLoop)
If oLeastProgress Is Nothing Then
'nothing to compare yet
Set oLeastProgress = oListLoop
Else
If oListLoop.PercentageDone < oLeastProgress.PercentageDone Then
'definitely take this new candidate
Set oLeastProgress = oListLoop
ElseIf oListLoop.PercentageDone = oLeastProgress.PercentageDone And oListLoop.Size > oListLoop.Size Then
'close thing, both showing equal progress but we should give it to the one with the bigger "queue"
Set oLeastProgress = oListLoop
Else
'no swap
End If
End If
Next
'return the answer
Set WhichListHasLeastProgress = oLeastProgress
End Function
and the List.cls file is
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "List"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private mvList As Variant
Private mlCount As Long
Private mlCursor As Long
Private mvName As Variant
Public Function Initialise(ByRef vList As Variant, ByVal vName As Variant)
Debug.Assert TypeName(vList(1, 1)) <> "" ' this will break unless you specify a 2d array
Debug.Assert LBound(vList, 1) = 1 ' this ensure you got it from a sheet
mvList = vList
mlCount = UBound(mvList)
mlCursor = 1
mvName = vName
End Function
Public Function GetListItem()
GetListItem = mvList(mlCursor, 1)
End Function
Public Function Name() As Variant
Name = mvName
End Function
Public Function MoveNext() As Boolean
mlCursor = mlCursor + 1
MoveNext = (mlCursor < mlCount)
End Function
Public Function Size() As Long
Size = mlCount
End Function
Public Function PercentageDone() As Double
PercentageDone = mlCursor / mlCount
End Function
The last file is this tstListManager.bas
Attribute VB_Name = "tstListManager"
Option Explicit
Sub test()
Dim oListMan As ListManager
Set oListMan = New ListManager
Dim vLists As Variant
vLists = VBA.Array(ThisWorkbook.Sheets("Source").Range("A1:A3").Value2, _
ThisWorkbook.Sheets("Source").Range("B1:B2").Value2, _
ThisWorkbook.Sheets("Source").Range("C1:C5").Value2)
oListMan.Initialise vLists
Dim vSorted As Variant
vSorted = oListMan.WeaveSort
Dim lTotal As Long
ThisWorkbook.Sheets("Dest").Range("A1").Resize(UBound(vSorted, 1)).Value2 = vSorted
End Sub
Finally, the test data was in A1:A3 B1:B2 C1:C5
You should note I have abstracted away any Excel reading/writing logic and the pure weavesort logic is not cluttered.
Feel free to reject outright. Object orientation can be quite controversial and we think differently. :)
Can you create an Excel VBA function that returns an array in the same manner as LINEST does, for example? I would to create one that, given a supplier code, returns a list of products for that supplier from a product-supplier table.
ok, here I have a function datamapping that returns an array of multiple 'columns', so you can shrink this down just to one.
Doesn't really matter how the array gets populated, particularly
Function dataMapping(inMapSheet As String) As String()
Dim mapping() As String
Dim lastMapRowNum As Integer
lastMapRowNum = ActiveWorkbook.Worksheets(inMapSheet).Cells.SpecialCells(xlCellTypeLastCell).Row
ReDim mapping(lastMapRowNum, 3) As String
For i = 1 To lastMapRowNum
If ActiveWorkbook.Worksheets(inMapSheet).Cells(i, 1).Value <> "" Then
mapping(i, 1) = ActiveWorkbook.Worksheets(inMapSheet).Cells(i, 1).Value
mapping(i, 2) = ActiveWorkbook.Worksheets(inMapSheet).Cells(i, 2).Value
mapping(i, 3) = ActiveWorkbook.Worksheets(inMapSheet).Cells(i, 3).Value
End If
Next i
dataMapping = mapping
End Function
Sub mysub()
Dim myMapping() As String
Dim m As Integer
myMapping = dataMapping(inDataMap)
For m = 1 To UBound(myMapping)
' do some stuff
Next m
end sub
I think Collection might be what you are looking for.
Example:
Private Function getProducts(ByVal supplier As String) As Collection
Dim getProducts_ As New Collection
If supplier = "ACME" Then
getProducts_.Add ("Anvil")
getProducts_.Add ("Earthquake Pills")
getProducts_.Add ("Dehydrated Boulders")
getProducts_.Add ("Disintegrating Pistol")
End If
Set getProducts = getProducts_
Set getProducts_ = Nothing
End Function
Private Sub fillProducts()
Dim products As Collection
Set products = getProducts("ACME")
For i = 1 To products.Count
Sheets(1).Cells(i, 1).Value = products(i)
Next i
End Sub
Edit:
Here is a pretty simple solution to the Problem: Populating a ComboBox for Products whenever the ComboBox for Suppliers changes it's value with as little vba as possible.
Public Function getProducts(ByVal supplier As String) As Collection
Dim getProducts_ As New Collection
Dim numRows As Long
Dim colProduct As Integer
Dim colSupplier As Integer
colProduct = 1
colSupplier = 2
numRows = Sheets(1).Cells(1, colProduct).CurrentRegion.Rows.Count
For Each Row In Sheets(1).Range(Sheets(1).Cells(1, colProduct), Sheets(1).Cells(numRows, colSupplier)).Rows
If supplier = Row.Cells(1, colSupplier) Then
getProducts_.Add (Row.Cells(1, colProduct))
End If
Next Row
Set getProducts = getProducts_
Set getProducts_ = Nothing
End Function
Private Sub comboSupplier_Change()
comboProducts.Clear
For Each Product In getProducts(comboSupplier)
comboProducts.AddItem (Product)
Next Product
End Sub
Notes: I named the ComboBox for Suppliers comboSupplier and the one for Products comboProducts.