如何将 Excel VBA class 集合合并到 interface/factory 方法中？
How to incorporate Excel VBA class collection into interface/factory method?
我已经使用 class 模块将近一年了，现在我对它们很满意table。现在，我正在尝试将工厂方法合并到工作簿 table 中的数据提取中。我发现了一些关于 here, here, and here 主题的很棒的指南，但我不确定在哪里合并 class.
的集合
到目前为止，我已经用这种格式的独立集合设置了我的 class 模块：
Class 模块 OrigClass
Option Explicit
'Col position references for input table, only includes cols with relevant data
Private Enum icrColRef
icrName = 2
icrCost = 4
End Enum
'UDT mirrors class properties
Private Type TTestClass
Name As String
Cost As Long
End Type
Const WS_NAME As String = "Sheet1"
Const NR_TBL As String = "Table1"
Private msTestClass As Collection
Private TestClass As TTestClass
Private Sub Class_Initialize()
Set msTestClass = New Collection
End Sub
Public Sub Add(Item As OrigClass)
msTestClass.Add _
Item:=Item, _
Key:=Item.Name
End Sub
Public Function Extract() As OrigClass
Dim tblInputs As ListObject
Dim i As Integer
Dim Item As OrigClass
Set tblInputs = ThisWorkbook.Worksheets(WS_NAME).ListObjects(NR_TBL)
For i = 1 To tblInputs.DataBodyRange.Rows.Count
Set Item = New OrigClass
With Item
.Name = tblInputs.DataBodyRange(i, icrName).Value
.Cost = tblInputs.DataBodyRange(i, icrCost).Value
End With
msTestClass.Add Item
Next i
End Function
Public Function Item(i As Variant) As OrigClass
Set Item = msTestClass.Item(i)
End Function
Public Function Count() As Integer
Count = msTestClass.Count
End Function
Friend Property Let Name(Val As String)
TestClass.Name = Val
End Property
Public Property Get Name() As String
Name = TestClass.Name
End Property
Friend Property Let Cost(Val As Long)
TestClass.Cost = Val
End Property
Public Property Get Cost() As Long
Cost = TestClass.Cost
End Property
当我构建传递 ranges/table 的函数、遍历行并为每个 属性 分配一个列值时，此结构运行良好。地址几乎总是不变的，只有值和记录数会有所不同。
我刚刚开始为 class 构建一个接口，同时还试图保留集合组件，但我遇到了运行时错误......我可能 create a separate collection class，但我认为我的问题更多是关于范围管理不善而不是封装：
Class 模块 CTestClass
Option Explicit
'Col position references for input table, only includes cols with relevant data
Private Enum icrColRef
icrName = 2
icrCost = 4
End Enum
''UDT mirrors class properties
Private Type TTestClass
Name As String
Cost As Long
End Type
Const WS_NAME As String = "Sheet1"
Const NR_TBL As String = "Table1"
Private msTestClass As Collection
Private TestClass As TTestClass
Implements ITestClass
Implements FTestClass
Private Sub Class_Initialize()
Set msTestClass = New Collection
End Sub
Public Sub Add(Item As CTestClass)
msTestClass.Add _
Item:=Item, _
Key:=Item.Name
End Sub
Public Function Create() As ITestClass
With New CTestClass
.Extract
' 2) now in Locals window, Me.msTestClass is <No Variables>
Set Create = .Self
' 4) Me.msTestClass is again <No Variables>, and
' Create (as Type ITextClass) is Nothing
' Create (as Type ITextClass/ITextClass) lists property values as
' <Object doesn't support this property or method>, aka runtime error 438
End With
End Function
Private Function FTestClass_Create() As ITestClass
Set FTestClass_Create = Create
End Function
Public Function Extract() As ITestClass
Dim tblInputs As ListObject
Dim i As Integer
Dim Item As CTestClass
Set tblInputs = ThisWorkbook.Worksheets(WS_NAME).ListObjects(NR_TBL)
For i = 1 To tblInputs.DataBodyRange.Rows.Count
Set Item = New CTestClass
With Item
.Name = tblInputs.DataBodyRange(i, icrName).Value
.Cost = tblInputs.DataBodyRange(i, icrCost).Value
End With
msTestClass.Add Item
Next i
' 1) in Locals window, Me.msTestClass is populated with all table records
End Function
Public Function ITestClass_Item(i As Variant) As ITestClass
Set ITestClass_Item = msTestClass.Item(i)
End Function
Public Function ITestClass_Count() As Integer
ITestClass_Count = msTestClass.Count
End Function
Friend Property Let Name(Val As String)
TestClass.Name = Val
End Property
Public Property Get Name() As String
Name = TestClass.Name
End Property
Friend Property Let Cost(Val As Long)
TestClass.Cost = Val
End Property
Public Property Get Cost() As Long
Cost = TestClass.Cost
End Property
Public Property Get Self() As ITestClass
Set Self = Me
' 3) Me.msTestClass is again populated with all table records (scope shift?), but
' Self is set to Nothing
End Property
Private Property Get ITestClass_Name() As String
ITestClass_Name = Name
End Property
Private Property Get ITestClass_Cost() As Long
ITestClass_Cost = Cost
End Property
接口模块ITestClass
'Attribute VB_PredeclaredId = False <-- revised in text editor
Option Explicit
Public Function Item(i As Variant) As ITestClass
End Function
Public Function Count() As Integer
End Function
Public Property Get Name() As String
End Property
Public Property Get Cost() As Long
End Property
工厂模块 FTestClass
'Attribute VB_PredeclaredId = False <-- revised in text editor
Option Explicit
Public Function Create() As ITestClass
End Function
标准模块
Sub TestFactory()
Dim i As ITestClass
Dim oTest As FTestClass
Set oTest = CTestClass.Create
' 5) oTest is <No Variables>, no properties are present
' as if the variable was never set
For Each i In oTest ' <-- Runtime error 438, Object doesn't support this property or method
Debug.Print
Debug.Print i.Name
Debug.Print i.Cost
Next i
End Sub
我做错了什么？
编辑：
@freeflow 指出我没有说明引入接口的意图。
我的办公室使用多个工作簿“模型”将定价数据编译成单个输出 table，然后将其交付给下游客户以导入数据库。
我的目标是使用这些不同的模型来标准化计算。附带目标是了解如何正确实施工厂方法。
每个模型都有一个或多个输入 table，每个 table 包含 10-30 fields/columns 的唯一集合。输出数据计算各不相同，以及对各种输入字段的依赖性。但是，输出数据的格式完全相同，并且始终包含相同的十几个字段。
我展示的示例旨在成为一个单一接口 ITestClass，用于将数据写入输出 table。实现它的 class CTestClass 可以被认为只是包含输入数据的几个 table 之一（在几个模型中）。我计划对更多 class 个对象建模，每个输入一个 table。
基于：
Sub TestFactory()
Dim i As ITestClass
Dim oTest As FTestClass
Set oTest = CTestClass.Create
' 5) oTest is <No Variables>, no properties are present
' as if the variable was never set
For Each i In oTest ' <-- Runtime error 438, Object doesn't support this property or method
Debug.Print
Debug.Print i.Name
Debug.Print i.Cost
Next i
End Sub
看来您有兴趣使 class 像集合一样可迭代。我会向您指出 this SO question。缺点是……很难。
关于错误：语句 Set oTest = CTestClass.Create 的结果是获取公开单个方法的 FTestClass 接口：Public Function Create() As ITestClass。其中，没有提供任何迭代 on 并导致错误。
其他观察：
在提供的代码中，无需声明工厂接口。
（补充说明：接口 class 通常以字母“I”开头。在这种情况下，FTestClass 的更好接口名称是“ITestClassFactory”）
由于 CTestClass 将其 VB_PredeclaredId 属性设置为 'True'，因此在 CTestClass 中声明的任何 Public 方法（或字段）都会公开...并被视为其默认界面。 CTestClass.Create()是您感兴趣的工厂方法。
创建工厂方法（在 VBA 中）的一个目的是支持 class 实例的参数化创建。由于 Create 函数目前没有参数，因此不清楚在创建过程中除了 Set tClass = new CTestClass 还会发生什么。但是，有 个参数可以指示 Create 期间发生的事情。
Public Function Create(ByVal tblInputs As ListObject, OPtional ByVal nameColumn As Long = 2, Optional ByVal costColumn As Long = 4) As ITestClass
换句话说，CTestClass 依赖于 ListObject 才能成为 CTestClass 的有效实例。工厂方法的签名通常包含 class 的依赖项。使用上述工厂方法，不再需要 Extract 函数 - Public 或其他。另请注意（在下面的代码中）ThisWorkbook 引用不再是对象的一部分。现在，tblInputs ListObject 可以来自任何地方。并且可以轻松修改重要的列号。此参数列表允许您使用带有假数据的工作表来测试此 class。
重组：
CTestClass 包含 Collection 个 CTestClass 个实例。声明一个暴露上面 Create 函数的 TestClassContainer class 似乎更清楚。然后容器 class 可以公开一个 NameCostPairs 属性，它只公开 msTestClass Collection。创建容器 class 将 TestClass 本质上减少为一个数据对象（所有属性，没有方法），从而实现有用的关注点分离。让调用对象处理集合的迭代。
测试类容器
Option Explicit
Private Type TTestClassContainer
msTestClass As Collection
End Type
Private this As TTestClassContainer
'TestContainer Factory method
Public Function Create(ByVal tblInputs As ListObject, Optional ByVal nameCol As Long = 2, Optional ByVal costCol As Long = 4) As TestClassContainer
Dim i As Integer
Dim nameCostPair As CTestClass
Dim newInstance As TestClassContainer
With New TestClassContainer
Set newInstance = .Self
For i = 1 To tblInputs.DataBodyRange.Rows.Count
Set nameCostPair = New CTestClass
nameCostPair.Name = tblInputs.DataBodyRange(i, nameCol).Value
nameCostPair.Cost = tblInputs.DataBodyRange(i, costCol).Value
newInstance.AddTestClass nameCostPair
Next i
End With
Set Create = newInstance
End Function
Public Sub AddTestClass(ByVal tstClass As CTestClass)
this.msTestClass.Add tstClass
End Sub
Public Property Get Self() As CTestClass
Set Self = Me
End Property
Public Property Get NameCostPairs() As Collection
Set NameCostPairs = this.msTestClass
End Property
CTestClass（不再需要 VB_PredeclaredId 设置为 'True'）
Option Explicit
Implements ITestClass
''UDT mirrors class properties
Private Type TTestClass
Name As String
Cost As Long
End Type
Private this As TTestClass
Public Property Let Name(Val As String)
this.Name = Val
End Property
Public Property Get Name() As String
Name = this.Name
End Property
Public Property Let Cost(Val As Long)
this.Cost = Val
End Property
Public Property Get Cost() As Long
Cost = this.Cost
End Property
Private Property Get ITestClass_Name() As String
ITestClass_Name = Name
End Property
Private Property Get ITestClass_Cost() As Long
ITestClass_Cost = Cost
End Property
最后：
Option Explicit
Sub TestFactory()
Const WS_NAME As String = "Sheet1"
Const NR_TBL As String = "Table1"
Dim tblInputs As ListObject
Set tblInputs = ThisWorkbook.Worksheets(WS_NAME).ListObjects(NR_TBL)
Dim container As TestClassContainer
Set container = TestClassContainer.Create(tblInputs)
Dim nameCostPair As ITestClass
Dim containerItem As Variant
For Each containerItem In container.NameCostPairs
Set nameCostPair = containerItem
Debug.Print
Debug.Print nameCostPair.Name
Debug.Print nameCostPair.Cost
Next
End Sub
我看到@BZgr 提供了一个解决方案，但正如我也写的那样，我提供了下面的答案作为替代方案。
我认为 OP 代码有几个问题。
origclass 和 origclasses 的集合是合并的，它们应该是分开的。 origclass UDT 的糟糕命名并没有让解决这个问题变得更容易。
不清楚什么需要工厂。我将工厂方法放在 origclasses class 中，以便创建 origclass 的 'immutable' 集合。
不清楚op试图通过引入接口来实现什么。通常，当许多不同的对象必须提供同一组方法时，就会使用接口。在 VBA 中，接口声明允许编译器检查声称实现该接口的每个对象是否具有正确的方法和参数列表。 （但我承认可能有一些特殊的 VBA 情况并非如此）
下面的代码编译并且没有重要的 Rubberduck 检查。但是，我不是 Excel VBA 的用户，所以如果我的代码在这方面有错误，我提前道歉。
一个。我们有一个单独且非常简单的 OrigClass
Option Explicit
Private Type Properties
Name As String
Cost As Long
End Type
Private p As Properties
Public Property Get Name() As String
Name = p.Name
End Property
Public Property Let Name(ByVal ipString As String)
p.Name = ipString
End Property
Public Property Get Cost() As Long
Cost = p.Cost
End Property
Public Property Let Cost(ByVal ipCost As Long)
p.Cost = ipCost
End Property
2 OrigClaases class 是 origclass
的集合
Option Explicit
'@PredeclaredId
'@Exposed
'Col position references for input table, only includes cols with relevant data
Private Enum icrColRef
icrName = 2
icrCost = 4
End Enum
Private Type State
'TestClass As Collection
Host As Collection
ExternalData As Excel.Worksheet
TableName As String
End Type
Private s As State
Public Function Deb(ByVal ipWorksheet As Excel.Worksheet, ByVal ipTableName As String) As OrigClasses
With New OrigClasses
Set Deb = .ReadyToUseInstance(ipWorksheet, ipTableName)
End With
End Function
Friend Function ReadyToUseInstance(ByVal ipWorksheet As Excel.Worksheet, ByVal ipTableName As String) As OrigClasses
Set s.Host = New Collection
Set s.ExternalData = ipWorksheet
s.TableName = ipTableName
PopulateHost
Set ReadyToUseInstance = Me
End Function
' The fact that you are using the collection Key suggests
' you might be better of using a scripting.dictioanry
' Also given that you populate host doirectly from the worksheet
' this add method may now be redundant.
Public Sub Add(ByVal ipItem As OrigClass)
s.Host.Add _
Item:=ipItem, _
Key:=ipItem.Name
End Sub
Public Sub Extract()
' Extract is restricted to re extracting data
' should the worksheet have been changed.
' If you need to work on a new sheet then
' create a new OrigClasses object
Set s.Host = New Collection
PopulateHost
End Sub
Private Sub PopulateHost()
Dim tblInputs As ListObject
Set tblInputs = s.ExternalData.ListObjects(s.TableName)
Dim myRow As Long
For myRow = 1 To tblInputs.DataBodyRange.Rows.Count
Dim myItem As OrigClass
Set myItem = New OrigClass
With myItem
.Name = tblInputs.DataBodyRange(myRow, icrName).Value
.Cost = tblInputs.DataBodyRange(myRow, icrCost).Value
End With
s.Host.Add myItem, myItem.Name
Next
End Sub
Public Function Item(ByVal ipIndex As Variant) As OrigClass
Set Item = s.Host.Item(ipIndex)
End Function
Public Function Count() As Long
Count = s.Host.Count
End Function
Public Function Name(ByVal ipIndex As Long) As String
Name = s.Host.Item(ipIndex).Name
End Function
Public Function Cost(ByVal ipIndex As Long) As Long
Cost = s.Host.Item(ipIndex).Cost
End Function
Public Function SheetName() As String
SheetName = s.ExternalData.Name
End Function
Public Function TableName() As String
TableName = s.TableName
End Function
'@Enumerator
Public Function NewEnum() As IUnknown
Set NewEnum = s.Host.[_NewEnum]
End Function
c。测试代码
Option Explicit
Const WS_NAME As String = "Sheet1"
Const NR_TBL As String = "Table1"
Sub TestFactory()
Dim oTest As OrigClasses
'@Ignore UnassignedVariableUsage
Set oTest = OrigClasses.Deb(ThisWorkbook.Worksheets(WS_NAME), NR_TBL)
Dim myOrigClass As Variant
For Each myOrigClass In oTest
Debug.Print
Debug.Print myOrigClass.Name
Debug.Print myOrigClass.Cost
Next
End Sub
对于工厂方法，根据 Rubberduck 的反馈，我现在使用方法名称 'Deb'，它是 Debut（或 Debutante）的缩写，意思是已经准备好可以使用的东西。这当然导致了为什么我使用方法名称 'readytoUseInstance'.
我使用属性和状态的 UDT（带有变量 p 和 s）将外部属性与内部状态分开。
在方法中，我在变量前加上前缀 'my'。
对于方法参数，我使用带前缀的 ip、op 和 iop 仅用于输入、仅输出以及经过变异和输出的输入。
这些前缀 p、s、my、ip、op、iop 的一个附带好处是它们还消除了尝试命名 variables/parameters.
时遇到的大多数问题。
我已经使用 class 模块将近一年了，现在我对它们很满意table。现在，我正在尝试将工厂方法合并到工作簿 table 中的数据提取中。我发现了一些关于 here, here, and here 主题的很棒的指南，但我不确定在哪里合并 class.
的集合到目前为止，我已经用这种格式的独立集合设置了我的 class 模块：
Class 模块 OrigClass
Option Explicit
'Col position references for input table, only includes cols with relevant data
Private Enum icrColRef
icrName = 2
icrCost = 4
End Enum
'UDT mirrors class properties
Private Type TTestClass
Name As String
Cost As Long
End Type
Const WS_NAME As String = "Sheet1"
Const NR_TBL As String = "Table1"
Private msTestClass As Collection
Private TestClass As TTestClass
Private Sub Class_Initialize()
Set msTestClass = New Collection
End Sub
Public Sub Add(Item As OrigClass)
msTestClass.Add _
Item:=Item, _
Key:=Item.Name
End Sub
Public Function Extract() As OrigClass
Dim tblInputs As ListObject
Dim i As Integer
Dim Item As OrigClass
Set tblInputs = ThisWorkbook.Worksheets(WS_NAME).ListObjects(NR_TBL)
For i = 1 To tblInputs.DataBodyRange.Rows.Count
Set Item = New OrigClass
With Item
.Name = tblInputs.DataBodyRange(i, icrName).Value
.Cost = tblInputs.DataBodyRange(i, icrCost).Value
End With
msTestClass.Add Item
Next i
End Function
Public Function Item(i As Variant) As OrigClass
Set Item = msTestClass.Item(i)
End Function
Public Function Count() As Integer
Count = msTestClass.Count
End Function
Friend Property Let Name(Val As String)
TestClass.Name = Val
End Property
Public Property Get Name() As String
Name = TestClass.Name
End Property
Friend Property Let Cost(Val As Long)
TestClass.Cost = Val
End Property
Public Property Get Cost() As Long
Cost = TestClass.Cost
End Property
当我构建传递 ranges/table 的函数、遍历行并为每个 属性 分配一个列值时，此结构运行良好。地址几乎总是不变的，只有值和记录数会有所不同。
我刚刚开始为 class 构建一个接口，同时还试图保留集合组件，但我遇到了运行时错误......我可能 create a separate collection class，但我认为我的问题更多是关于范围管理不善而不是封装：
Class 模块 CTestClass
Option Explicit
'Col position references for input table, only includes cols with relevant data
Private Enum icrColRef
icrName = 2
icrCost = 4
End Enum
''UDT mirrors class properties
Private Type TTestClass
Name As String
Cost As Long
End Type
Const WS_NAME As String = "Sheet1"
Const NR_TBL As String = "Table1"
Private msTestClass As Collection
Private TestClass As TTestClass
Implements ITestClass
Implements FTestClass
Private Sub Class_Initialize()
Set msTestClass = New Collection
End Sub
Public Sub Add(Item As CTestClass)
msTestClass.Add _
Item:=Item, _
Key:=Item.Name
End Sub
Public Function Create() As ITestClass
With New CTestClass
.Extract
' 2) now in Locals window, Me.msTestClass is <No Variables>
Set Create = .Self
' 4) Me.msTestClass is again <No Variables>, and
' Create (as Type ITextClass) is Nothing
' Create (as Type ITextClass/ITextClass) lists property values as
' <Object doesn't support this property or method>, aka runtime error 438
End With
End Function
Private Function FTestClass_Create() As ITestClass
Set FTestClass_Create = Create
End Function
Public Function Extract() As ITestClass
Dim tblInputs As ListObject
Dim i As Integer
Dim Item As CTestClass
Set tblInputs = ThisWorkbook.Worksheets(WS_NAME).ListObjects(NR_TBL)
For i = 1 To tblInputs.DataBodyRange.Rows.Count
Set Item = New CTestClass
With Item
.Name = tblInputs.DataBodyRange(i, icrName).Value
.Cost = tblInputs.DataBodyRange(i, icrCost).Value
End With
msTestClass.Add Item
Next i
' 1) in Locals window, Me.msTestClass is populated with all table records
End Function
Public Function ITestClass_Item(i As Variant) As ITestClass
Set ITestClass_Item = msTestClass.Item(i)
End Function
Public Function ITestClass_Count() As Integer
ITestClass_Count = msTestClass.Count
End Function
Friend Property Let Name(Val As String)
TestClass.Name = Val
End Property
Public Property Get Name() As String
Name = TestClass.Name
End Property
Friend Property Let Cost(Val As Long)
TestClass.Cost = Val
End Property
Public Property Get Cost() As Long
Cost = TestClass.Cost
End Property
Public Property Get Self() As ITestClass
Set Self = Me
' 3) Me.msTestClass is again populated with all table records (scope shift?), but
' Self is set to Nothing
End Property
Private Property Get ITestClass_Name() As String
ITestClass_Name = Name
End Property
Private Property Get ITestClass_Cost() As Long
ITestClass_Cost = Cost
End Property
接口模块ITestClass
'Attribute VB_PredeclaredId = False <-- revised in text editor
Option Explicit
Public Function Item(i As Variant) As ITestClass
End Function
Public Function Count() As Integer
End Function
Public Property Get Name() As String
End Property
Public Property Get Cost() As Long
End Property
工厂模块 FTestClass
'Attribute VB_PredeclaredId = False <-- revised in text editor
Option Explicit
Public Function Create() As ITestClass
End Function
标准模块
Sub TestFactory()
Dim i As ITestClass
Dim oTest As FTestClass
Set oTest = CTestClass.Create
' 5) oTest is <No Variables>, no properties are present
' as if the variable was never set
For Each i In oTest ' <-- Runtime error 438, Object doesn't support this property or method
Debug.Print
Debug.Print i.Name
Debug.Print i.Cost
Next i
End Sub
我做错了什么？
编辑：
@freeflow 指出我没有说明引入接口的意图。
我的办公室使用多个工作簿“模型”将定价数据编译成单个输出 table，然后将其交付给下游客户以导入数据库。
我的目标是使用这些不同的模型来标准化计算。附带目标是了解如何正确实施工厂方法。
每个模型都有一个或多个输入 table，每个 table 包含 10-30 fields/columns 的唯一集合。输出数据计算各不相同，以及对各种输入字段的依赖性。但是，输出数据的格式完全相同，并且始终包含相同的十几个字段。
我展示的示例旨在成为一个单一接口 ITestClass，用于将数据写入输出 table。实现它的 class CTestClass 可以被认为只是包含输入数据的几个 table 之一（在几个模型中）。我计划对更多 class 个对象建模，每个输入一个 table。
基于：
Sub TestFactory()
Dim i As ITestClass
Dim oTest As FTestClass
Set oTest = CTestClass.Create
' 5) oTest is <No Variables>, no properties are present
' as if the variable was never set
For Each i In oTest ' <-- Runtime error 438, Object doesn't support this property or method
Debug.Print
Debug.Print i.Name
Debug.Print i.Cost
Next i
End Sub
看来您有兴趣使 class 像集合一样可迭代。我会向您指出 this SO question。缺点是……很难。
关于错误：语句 Set oTest = CTestClass.Create 的结果是获取公开单个方法的 FTestClass 接口：Public Function Create() As ITestClass。其中，没有提供任何迭代 on 并导致错误。
其他观察：
在提供的代码中，无需声明工厂接口。
（补充说明：接口 class 通常以字母“I”开头。在这种情况下，FTestClass 的更好接口名称是“ITestClassFactory”）
由于 CTestClass 将其 VB_PredeclaredId 属性设置为 'True'，因此在 CTestClass 中声明的任何 Public 方法（或字段）都会公开...并被视为其默认界面。 CTestClass.Create()是您感兴趣的工厂方法。
创建工厂方法（在 VBA 中）的一个目的是支持 class 实例的参数化创建。由于 Create 函数目前没有参数，因此不清楚在创建过程中除了 Set tClass = new CTestClass 还会发生什么。但是，有 个参数可以指示 Create 期间发生的事情。
Public Function Create(ByVal tblInputs As ListObject, OPtional ByVal nameColumn As Long = 2, Optional ByVal costColumn As Long = 4) As ITestClass
换句话说，CTestClass 依赖于 ListObject 才能成为 CTestClass 的有效实例。工厂方法的签名通常包含 class 的依赖项。使用上述工厂方法，不再需要 Extract 函数 - Public 或其他。另请注意（在下面的代码中）ThisWorkbook 引用不再是对象的一部分。现在，tblInputs ListObject 可以来自任何地方。并且可以轻松修改重要的列号。此参数列表允许您使用带有假数据的工作表来测试此 class。
重组：
CTestClass 包含 Collection 个 CTestClass 个实例。声明一个暴露上面 Create 函数的 TestClassContainer class 似乎更清楚。然后容器 class 可以公开一个 NameCostPairs 属性，它只公开 msTestClass Collection。创建容器 class 将 TestClass 本质上减少为一个数据对象（所有属性，没有方法），从而实现有用的关注点分离。让调用对象处理集合的迭代。
测试类容器
Option Explicit
Private Type TTestClassContainer
msTestClass As Collection
End Type
Private this As TTestClassContainer
'TestContainer Factory method
Public Function Create(ByVal tblInputs As ListObject, Optional ByVal nameCol As Long = 2, Optional ByVal costCol As Long = 4) As TestClassContainer
Dim i As Integer
Dim nameCostPair As CTestClass
Dim newInstance As TestClassContainer
With New TestClassContainer
Set newInstance = .Self
For i = 1 To tblInputs.DataBodyRange.Rows.Count
Set nameCostPair = New CTestClass
nameCostPair.Name = tblInputs.DataBodyRange(i, nameCol).Value
nameCostPair.Cost = tblInputs.DataBodyRange(i, costCol).Value
newInstance.AddTestClass nameCostPair
Next i
End With
Set Create = newInstance
End Function
Public Sub AddTestClass(ByVal tstClass As CTestClass)
this.msTestClass.Add tstClass
End Sub
Public Property Get Self() As CTestClass
Set Self = Me
End Property
Public Property Get NameCostPairs() As Collection
Set NameCostPairs = this.msTestClass
End Property
CTestClass（不再需要 VB_PredeclaredId 设置为 'True'）
Option Explicit
Implements ITestClass
''UDT mirrors class properties
Private Type TTestClass
Name As String
Cost As Long
End Type
Private this As TTestClass
Public Property Let Name(Val As String)
this.Name = Val
End Property
Public Property Get Name() As String
Name = this.Name
End Property
Public Property Let Cost(Val As Long)
this.Cost = Val
End Property
Public Property Get Cost() As Long
Cost = this.Cost
End Property
Private Property Get ITestClass_Name() As String
ITestClass_Name = Name
End Property
Private Property Get ITestClass_Cost() As Long
ITestClass_Cost = Cost
End Property
最后：
Option Explicit
Sub TestFactory()
Const WS_NAME As String = "Sheet1"
Const NR_TBL As String = "Table1"
Dim tblInputs As ListObject
Set tblInputs = ThisWorkbook.Worksheets(WS_NAME).ListObjects(NR_TBL)
Dim container As TestClassContainer
Set container = TestClassContainer.Create(tblInputs)
Dim nameCostPair As ITestClass
Dim containerItem As Variant
For Each containerItem In container.NameCostPairs
Set nameCostPair = containerItem
Debug.Print
Debug.Print nameCostPair.Name
Debug.Print nameCostPair.Cost
Next
End Sub
我看到@BZgr 提供了一个解决方案，但正如我也写的那样，我提供了下面的答案作为替代方案。
我认为 OP 代码有几个问题。
origclass 和 origclasses 的集合是合并的，它们应该是分开的。 origclass UDT 的糟糕命名并没有让解决这个问题变得更容易。
不清楚什么需要工厂。我将工厂方法放在 origclasses class 中，以便创建 origclass 的 'immutable' 集合。
不清楚op试图通过引入接口来实现什么。通常，当许多不同的对象必须提供同一组方法时，就会使用接口。在 VBA 中，接口声明允许编译器检查声称实现该接口的每个对象是否具有正确的方法和参数列表。 （但我承认可能有一些特殊的 VBA 情况并非如此）
下面的代码编译并且没有重要的 Rubberduck 检查。但是，我不是 Excel VBA 的用户，所以如果我的代码在这方面有错误，我提前道歉。
一个。我们有一个单独且非常简单的 OrigClass
Option Explicit
Private Type Properties
Name As String
Cost As Long
End Type
Private p As Properties
Public Property Get Name() As String
Name = p.Name
End Property
Public Property Let Name(ByVal ipString As String)
p.Name = ipString
End Property
Public Property Get Cost() As Long
Cost = p.Cost
End Property
Public Property Let Cost(ByVal ipCost As Long)
p.Cost = ipCost
End Property
2 OrigClaases class 是 origclass
的集合Option Explicit
'@PredeclaredId
'@Exposed
'Col position references for input table, only includes cols with relevant data
Private Enum icrColRef
icrName = 2
icrCost = 4
End Enum
Private Type State
'TestClass As Collection
Host As Collection
ExternalData As Excel.Worksheet
TableName As String
End Type
Private s As State
Public Function Deb(ByVal ipWorksheet As Excel.Worksheet, ByVal ipTableName As String) As OrigClasses
With New OrigClasses
Set Deb = .ReadyToUseInstance(ipWorksheet, ipTableName)
End With
End Function
Friend Function ReadyToUseInstance(ByVal ipWorksheet As Excel.Worksheet, ByVal ipTableName As String) As OrigClasses
Set s.Host = New Collection
Set s.ExternalData = ipWorksheet
s.TableName = ipTableName
PopulateHost
Set ReadyToUseInstance = Me
End Function
' The fact that you are using the collection Key suggests
' you might be better of using a scripting.dictioanry
' Also given that you populate host doirectly from the worksheet
' this add method may now be redundant.
Public Sub Add(ByVal ipItem As OrigClass)
s.Host.Add _
Item:=ipItem, _
Key:=ipItem.Name
End Sub
Public Sub Extract()
' Extract is restricted to re extracting data
' should the worksheet have been changed.
' If you need to work on a new sheet then
' create a new OrigClasses object
Set s.Host = New Collection
PopulateHost
End Sub
Private Sub PopulateHost()
Dim tblInputs As ListObject
Set tblInputs = s.ExternalData.ListObjects(s.TableName)
Dim myRow As Long
For myRow = 1 To tblInputs.DataBodyRange.Rows.Count
Dim myItem As OrigClass
Set myItem = New OrigClass
With myItem
.Name = tblInputs.DataBodyRange(myRow, icrName).Value
.Cost = tblInputs.DataBodyRange(myRow, icrCost).Value
End With
s.Host.Add myItem, myItem.Name
Next
End Sub
Public Function Item(ByVal ipIndex As Variant) As OrigClass
Set Item = s.Host.Item(ipIndex)
End Function
Public Function Count() As Long
Count = s.Host.Count
End Function
Public Function Name(ByVal ipIndex As Long) As String
Name = s.Host.Item(ipIndex).Name
End Function
Public Function Cost(ByVal ipIndex As Long) As Long
Cost = s.Host.Item(ipIndex).Cost
End Function
Public Function SheetName() As String
SheetName = s.ExternalData.Name
End Function
Public Function TableName() As String
TableName = s.TableName
End Function
'@Enumerator
Public Function NewEnum() As IUnknown
Set NewEnum = s.Host.[_NewEnum]
End Function
c。测试代码
Option Explicit
Const WS_NAME As String = "Sheet1"
Const NR_TBL As String = "Table1"
Sub TestFactory()
Dim oTest As OrigClasses
'@Ignore UnassignedVariableUsage
Set oTest = OrigClasses.Deb(ThisWorkbook.Worksheets(WS_NAME), NR_TBL)
Dim myOrigClass As Variant
For Each myOrigClass In oTest
Debug.Print
Debug.Print myOrigClass.Name
Debug.Print myOrigClass.Cost
Next
End Sub
对于工厂方法，根据 Rubberduck 的反馈，我现在使用方法名称 'Deb'，它是 Debut（或 Debutante）的缩写，意思是已经准备好可以使用的东西。这当然导致了为什么我使用方法名称 'readytoUseInstance'.
我使用属性和状态的 UDT（带有变量 p 和 s）将外部属性与内部状态分开。
在方法中，我在变量前加上前缀 'my'。
对于方法参数，我使用带前缀的 ip、op 和 iop 仅用于输入、仅输出以及经过变异和输出的输入。
这些前缀 p、s、my、ip、op、iop 的一个附带好处是它们还消除了尝试命名 variables/parameters.
时遇到的大多数问题。