Question

我是VBA的新手，因为我通常使用SQL或MATLAB进行大部分Excel / Access操作。（事实上，我已经在MATLAB中解决了以下问题）

我正在尝试拉出一个代表图表的表格，其格式如下：

O       D       SLOC    ELOC
0113    1246    0113    1246 
0113    1724    0113    06NC 
0113    1724    0113    1246 
0113    1724    06NC    1724 
0113    1724    1246    1724

O是最终起源，D是图表上不同实体的最终目的地。 SLOC是实体的起始位置，ELOC将是该实体的下一个目的地。因此，例如，实体从0113到1724的路线可以跟随0113-06NC-1724或0113-1246-1724。

我需要输出的表是同一个表，只压缩到每个O和D只有1行的位置。它的格式如下（使用上述数据）：

Route#    O     D     I1    I2    I3    I4    I5    I6
1         0113  0246
1         0113  1724  06NC
2         0113  1724  1246

I1到I6是每个O和D之间的中间停靠点，路由号码允许我稍后根据Route＃，O和D创建主键。

我真的很想知道如何在不使用SQL查询的情况下拉出与给定（和每个给定的）OD对匹配的所有行（如果在循环中使用，则需要永远......）。如果我可以在某种数据结构中获取行，那么我可以迭代并找到所有路由。

因此，我的问题是，如何创建一个循环来拉动给定每个O-D对的所有行？提前谢谢！

Answer 1

这是我将如何做到的。创建名为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

Answer 2

我不确定这是否是您正在寻找的答案，但如果我理解正确的话，也许这将是一个起点。此例程假设数据从“A1”开始，过滤并选择相关的行。一个“演示”，但也许会帮助你“绊倒”你的领域。

Sub myFilter()
    Dim w As Worksheet
    Dim rB As Range
    Dim rD As Range
    Dim rV As Range

    On Error GoTo errTrap

    Set w = ThisWorkbook.Worksheets(1) 'change to suit
    With w
        .AutoFilterMode = False
        Set rB = .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft)) 'data width
        Set rB = rB.Resize(.Cells(.Rows.CountLarge, 1).End(xlUp).Row) 'data height
        Set rD = rB.Offset(1).Resize(rB.Rows.Count - 1) 'data wo headers
    End With
    rB.AutoFilter field:=1, Criteria1:="113" 'change as req'd
    rB.AutoFilter field:=2, Criteria1:="1724" 'change as req'd

    Set rV = rD.SpecialCells(xlCellTypeVisible)
    rV.Select

errTrap:
    w.AutoFilterMode = False
End Sub

使用VBA的压缩表

2 个答案: