这就是我将如何做到的。创建一个名为 CRoute 的自定义类模块
Option Explicit
Private mlRouteID As Long
Private msOrigin As String
Private msDestination As String
Private mclsLegs As CRoutes
Private mlParentPtr As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(dest As Any, Source As Any, ByVal bytes As Long)
Public Property Set Legs(ByVal clsLegs As CRoutes): Set mclsLegs = clsLegs: End Property
Public Property Get Legs() As CRoutes: Set Legs = mclsLegs: End Property
Public Property Let RouteID(ByVal lRouteID As Long): mlRouteID = lRouteID: End Property
Public Property Get RouteID() As Long: RouteID = mlRouteID: End Property
Public Property Let Origin(ByVal sOrigin As String): msOrigin = sOrigin: End Property
Public Property Get Origin() As String: Origin = msOrigin: End Property
Public Property Let Destination(ByVal sDestination As String): msDestination = sDestination: End Property
Public Property Get Destination() As String: Destination = msDestination: End Property
Public Property Get Parent() As CRoutes: Set Parent = ObjFromPtr(mlParentPtr): End Property
Public Property Set Parent(obj As CRoutes): mlParentPtr = ObjPtr(obj): End Property
Private Function ObjFromPtr(ByVal pObj As Long) As Object
Dim obj As Object
CopyMemory obj, pObj, 4
Set ObjFromPtr = obj
' manually destroy the temporary object variable
' (if you omit this step you'll get a GPF!)
CopyMemory obj, 0&, 4
End Function
Public Property Get Od() As String
Od = Me.Origin & Me.Destination
End Property
Private Sub Class_Initialize()
Set mclsLegs = New CRoutes
End Sub
Private Sub Class_Terminate()
Set mclsLegs = Nothing
End Sub
Public Property Get LegFits(clsLeg As CRoute) As Boolean
Dim clsChildLeg As CRoute
Dim bReturn As Boolean
If clsLeg.Origin = Me.Origin And Me.HasNoOrigin Then
bReturn = True
Else
For Each clsChildLeg In Me.Legs
If clsLeg.Origin = clsChildLeg.Destination Then
bReturn = True
Exit For
End If
Next clsChildLeg
End If
LegFits = bReturn
End Property
Public Property Get HasNoOrigin() As Boolean
Dim clsLeg As CRoute
Dim bReturn As Boolean
bReturn = True
For Each clsLeg In Me.Legs
If clsLeg.Origin = Me.Origin Then
bReturn = False
Exit For
End If
Next clsLeg
HasNoOrigin = bReturn
End Property
然后创建一个名为 CRoutes 的自定义类模块
Option Explicit
Private mcolRoutes As Collection
Private Sub Class_Initialize()
Set mcolRoutes = New Collection
End Sub
Private Sub Class_Terminate()
Set mcolRoutes = Nothing
End Sub
Public Property Get NewEnum() As IUnknown
Set NewEnum = mcolRoutes.[_NewEnum]
End Property
Public Sub Add(clsRoute As CRoute)
If clsRoute.RouteID = 0 Then
clsRoute.RouteID = Me.Count + 1
End If
Set clsRoute.Parent = Me
mcolRoutes.Add clsRoute, CStr(clsRoute.RouteID)
End Sub
Public Property Get Route(vItem As Variant) As CRoute
Set Route = mcolRoutes.Item(vItem)
End Property
Public Property Get Count() As Long
Count = mcolRoutes.Count
End Property
Public Property Get RouteByLeg(ByVal clsLeg As CRoute)
Dim clsReturn As CRoute
Dim clsRoute As CRoute
For Each clsRoute In Me
If clsRoute.LegFits(clsLeg) Then
Set clsReturn = clsRoute
Exit For
End If
Next clsRoute
Set RouteByLeg = clsReturn
End Property
Public Property Get FilterByOd(ByVal sOd As String) As CRoutes
Dim clsReturn As CRoutes
Dim clsRoute As CRoute
Set clsReturn = New CRoutes
For Each clsRoute In Me
If clsRoute.Od = sOd Then
clsReturn.Add clsRoute
End If
Next clsRoute
Set FilterByOd = clsReturn
End Property
Public Property Get CondensedTable() As Variant
Dim aReturn() As Variant
Dim clsRoute As CRoute
Dim clsLeg As CRoute
Dim lMaxLegs As Long
Dim lCnt As Long, lLegCnt As Long
Const lRTECOLS As Long = 2
lMaxLegs = Me.MaxLegs
ReDim aReturn(1 To Me.Count, 1 To lRTECOLS + lMaxLegs - 1)
For Each clsRoute In Me
lCnt = lCnt + 1
lLegCnt = 0
aReturn(lCnt, 1) = "'" & clsRoute.Origin
aReturn(lCnt, 2) = "'" & clsRoute.Destination
For Each clsLeg In clsRoute.Legs
If clsLeg.Destination <> clsRoute.Destination Then
lLegCnt = lLegCnt + 1
aReturn(lCnt, lRTECOLS + lLegCnt) = "'" & clsLeg.Destination
End If
Next clsLeg
Next clsRoute
CondensedTable = aReturn
End Property
Public Property Get MaxLegs() As Long
Dim clsRoute As CRoute
Dim lReturn As Long
For Each clsRoute In Me
If clsRoute.Legs.Count > lReturn Then
lReturn = clsRoute.Legs.Count
End If
Next clsRoute
MaxLegs = lReturn
End Property
最后，在其中创建一个标准模块
Public Sub Main()
Dim rCell As Range
Dim clsRoutes As CRoutes
Dim clsRoute As CRoute
Dim clsLeg As CRoute
Dim sRouteOd As String
Dim clsRoutesByOd As CRoutes
Dim vaOutput As Variant
Set clsRoutes = New CRoutes
For Each rCell In Sheet1.Range("A2:A6").Cells
sRouteOd = rCell.Value & rCell.Offset(0, 1).Value
Set clsRoutesByOd = clsRoutes.FilterByOd(sRouteOd)
Set clsLeg = New CRoute
clsLeg.Origin = rCell.Offset(0, 2).Value
clsLeg.Destination = rCell.Offset(0, 3).Value
Set clsRoute = clsRoutesByOd.RouteByLeg(clsLeg)
If clsRoute Is Nothing Then
Set clsRoute = New CRoute
clsRoute.Origin = rCell.Value
clsRoute.Destination = rCell.Offset(0, 1).Value
clsRoutes.Add clsRoute
End If
clsRoute.Legs.Add clsLeg
Next rCell
vaOutput = clsRoutes.CondensedTable
Sheet1.Range("G1").Resize(UBound(vaOutput, 1), UBound(vaOutput, 2)).Value = vaOutput
End Sub
您可以在此处下载示例工作簿http://dailydoseofexcel.com/excel/Routes.xlsm