VBA：如何通过集合、“迟到”字典、其他方式关联多个对象实例？

Posted 2023-02-23

【中文标题】VBA：如何通过集合、“迟到”字典、其他方式关联多个对象实例？

【英文标题】：VBA: How to associate multiple object instances via collections, 'late' dictionary, other ways?

【发布时间】：2021-12-30 05:54:48

【问题描述】：

我是 VBA 的新手，但我已经学到了很多东西并且从未发布过任何东西，所以如果我可能不清楚或遵循任何预期的约定，我深表歉意。 我创建了一个当前有 1 个类的接口。 我有一个子获取多个工作表，相关的命名范围和行数量，我用它来循环我需要组合在一起的分散数据。 一旦逐行读取数据，它就会实例化对象（该类通过从模块接收范围的公共 init 方法将数据从单元格中提取出来），然后我将它们添加到模块中的一个没有键的简单集合中。直到一切正常为止。

在某些情况下，我需要将对象实例相互关联，因为我需要在稍后阶段以稍微不同的方式处理它们。 （之后输出表中的更多列） 我在我的数据中添加了一个唯一标识符，仅由相关实例共享，但我很困惑。 我不知道如何从这里着手创建这样的协会。 这是阅读：

'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

这是写作部分：

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

非常感谢您的帮助，我已经从 *** 社区学到了很多东西，但是在这里我真的很困惑，出于性能原因，我不想恢复到循环中的循环。

编辑：添加类代码

' 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

【问题讨论】：

你是如何创建“唯一标识符”的？

只是与导入到 excelsheet 的范围内的单元格相关的类的属性，就像任何其他属性一样。

也许我应该重新表述我想要实现的目标。例如，我希望有多个附加集合，其中只有这些对象实例，这些对象实例由该属性组合在一起。所以重要的属性将是 2 个实例，不重要的属性将是 3 个实例，所有其他实例仍应在原始解决方案集合中。希望这是有道理的 :)

我想我明白你想要什么，字典是一种解决方案，但因为你只显示了部分代码，我不确定你是否充分利用了类对象的全部好处。当您同时使用 OOP 和结构化编程时，危险就在于过于复杂。

老实说，我认为你是对的。基本上除了获取范围和单元格值的 init 方法之外，我在类本​​身中并没有做很多事情。我基本上遮蔽了值和单元格引用（以创建动态和静态工作表）。然而，我正在尝试创造一些强大而灵活的东西。但收到消息，因此将添加减少变量的代码。

【参考方案1】：

使用以您的唯一 id 作为键并以对象集合作为值的 Dictionary 对象。例如，一些用于创建对象和调用方法的***代码。

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

Solution 类

Public amount As Long
Public ref As String
Public typ As String

一个Reporter 类来保存字典和集合

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

【讨论】：

当我阅读代码时，它似乎确实按照我的意愿行事。我会测试并让你知道。非常感谢您的帮助。

我没有足够的声望来投票，但这是出色的编码。这就像一个魅力，它被简化、强大但在未来易于管理。所以我投了大票:)