I created an interface with one class.
I have a sub fetching multiple sheets, related named ranges and row amounts and I use this to loop through data which I need to group together.
Once the data is read row by row it instantiates the objects (the class pulls the data out of the cells via public init method which receives the range from the module) and I add them in the module to a simple collection without key. Until here everything is working.
In some cases I have object instances which I need to relate to each other as I need to treat them in a slightly different way in a later stage. (More columns in the outputtables afterwards.)
I added a unique identifier in my data only shared by the related instances, but I do not know how to proceed from here to create such an association.
This is the reading:
'Create solution is placed between Class creation and sub to define the target sheets & ranges
Option Explicit
Sub ReadData(Solutions As Collection)
Set Solutions = New Collection
Dim Solution As Variant
Dim ws As Worksheet
Dim rng As Range
Dim rowamount As Long
'define length of range
rowamount = Worksheets("source").Range("Named_ranges").Rows.Count
Dim myrow As Integer
Dim suspectWorksheet As String
Dim TargetWorksheet As Worksheet
Dim TargetWorkRange As String
Dim TargetRangeCount As Integer
Dim x As Integer
For myrow = 1 To rowamount
'Identify the visible sheets from the source matrix & init worksheet
suspectWorksheet = Worksheets("source").Range("Named_ranges").Cells(myrow, 1)
Set TargetWorksheet = Worksheets(suspectWorksheet)
If TargetWorksheet.Visible = True Then
' Init the range variable and get the max amount of lines to scan
TargetWorkRange = Worksheets("source").Range("Named_ranges").Cells(myrow, 2)
TargetRangeCount = Worksheets("source").Range("Named_ranges").Cells(myrow, 3)
' Start the lineloop to inject the data into the class
For x = 1 To TargetRangeCount
Debug.Print "Loop " & x
'Is there an active line in the target range?
If Worksheets(suspectWorksheet).Range(TargetWorkRange).Cells(x + 1, 1) > 0 Then
Set rng = Worksheets(suspectWorksheet).Range(TargetWorkRange).Resize(1, 60).Offset(x, 0)
Set Solution = solutionClassFactory(rng)
Solutions.Add Solution
'Solution.PrintOut
End If
Next x
End If
Next myrow
Set TargetWorksheet = Nothing
End Sub
' Checks the type of solution and returns into a class
Function solutionClassFactory(rng As Range) As Variant
Dim solutionType As String
solutionType = rng.Cells(1, 51)
Dim Solution As Variant
Select Case solutionType
Case "something":
Set Solution = New something
End Select
Solution.Init rng
' solution is returned to be added to the main collection
Set solutionClassFactory = Solution
End Function
This is the writing part:
Sub Create()
Dim Solution As Variant
Dim Solutions As Collection
Dim TargetWorksheet As String
Dim i As Integer
'Define to which sheet it needs to be written
TargetWorksheet = "sheet"
ReadData Solutions
i = 5
For Each Solution In Solutions
Worksheets(TargetWorksheet).Cells(i, 1) = Solution.amount
'more
i = i +1
Next Solution
End Sub
I don't want to revert to loops in loops for performance reasons.
Class Code
' class derived from Solution interface
Option Explicit
' Implements Solution interfacs
Implements Solution
Private amount_ As Integer
Private amountRef_ As String
Private Sub Class_Initialize()
End Sub
Public Sub Init(rng As Range)
amount_ = rng.Cells(1, 1)
amountRef_ = "'" & rng.Parent.Name & "'!" & rng.Columns.Item(1).address
End Sub
Public Sub PrintOut()
Debug.Print amount_, TypeName(Me), linekey_ & vbNewLine;
Debug.Print amountRef_, TypeName(Me), linekeyRef_ & vbNewLine;
End Sub
Private Sub Class_Terminate()
' Debug.Print "WAN class instance deleted"
End Sub
Public Property Get amount() As Integer
amount = amount_
End Property
Public Property Let amount(ByVal Value As Integer)
amount = amount_
End Property
Public Property Get linekeyRef() As String
linekeyRef = linekeyRef_
End Property
Public Property Let linekeyRef(ByVal Value As String)
linekeyRef = linekeyRef_
End Property
' Implement required interface properties
Private Property Get Solution_address() As String
Solution_address = address
End Property
Using a Dictionary Object with your unique id as the key and a collection of objects as the values. For example, some top level code to create object and invoke methods.
Option Explicit
Sub Process()
Dim rep As reporter
Set rep = New reporter
Set rep.SourceRng = Sheets("source").Range("Named_ranges")
rep.readata
MsgBox rep.linecount & " lines read"
Set rep.DestRng = Sheets("Sheet5").Range("A1")
rep.writedata
Set rep.DestRng = Sheets("Sheet6").Range("A1")
rep.writedata_bytyp
MsgBox "Done"
End Sub
The Solution class
Public amount As Long
Public ref As String
Public typ As String
a Reporter class to hold the dictionary and collection
Private Solutions As New Collection
Private Things As Object
Public SourceRng As Range
Public DestRng As Range
Public linecount As Long
Const COL_TYPE = "AY" '51
Sub readata()
Dim i As Long, obj As Solution, v
Dim ws As Worksheet, sRng As String, rng As Range
Dim r As Long, rowcount As Long
Set Things = CreateObject("Scripting.Dictionary")
For i = 1 To SourceRng.Rows.Count
Set ws = Sheets(SourceRng.Cells(i, 1).Value2)
sRng = SourceRng.Cells(i, 2)
rowcount = SourceRng.Cells(i, 3)
If ws.Visible = True Then
Set rng = ws.Range(sRng)
For r = 2 To rowcount + 1
v = rng.Cells(r, 1).Value2
If v > 0 Then
Set obj = New Solution
obj.amount = v
obj.typ = Trim(rng.Cells(r, COL_TYPE))
obj.ref = ws.Name & "!" & rng.Cells(r, 1).Address
Solutions.Add obj
If Not Things.exists(obj.typ) Then
Things.Add obj.typ, New Collection
End If
Things(obj.typ).Add obj
linecount = linecount + 1
End If
Next
End If
Next
End Sub
Sub writedata()
Dim i As Long, obj
With DestRng
For Each obj In Solutions
i = i + 1
.Cells(i, 1) = obj.amount
.Cells(i, 2) = obj.typ
.Cells(i, 3) = obj.ref
Next
End With
End Sub
Sub writedata_bytyp()
Dim i As Long, key, obj
With DestRng
For Each key In Things.keys
i = i + 1
.Cells(i, 1) = key
For Each obj In Things(key)
i = i + 1
.Cells(i, 2) = obj.amount
.Cells(i, 3) = obj.typ
.Cells(i, 4) = obj.ref
Next
Next
End With
End Sub