Condense Table using VBA

Question

I am really new to VBA, as I usually do most of my Excel/Access manipulation using SQL or MATLAB. (In fact, I've already solved the below problem in MATLAB)

I'm trying to pull a table, representative of a graph, that is formatted like the following:

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 is the ultimate origin and D is the ultimate destination for different entities on a graph. SLOC is the starting location of the entity and ELOC would be the next destination of the entity. So, for example, the route that an entity going from 0113 to 1724 could either follow 0113-06NC-1724 or 0113-1246-1724.

The table that I need to output from this is the same table, only condensed to where there is only 1 row per O and D. It would be formatted like the following (using the data described above):

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

I1 through I6 are all the intermediate stops between each O and D, and the route number would allow me to later create a primary key based on Route#, O, and D.

I'm really getting tripped up on how I can pull all rows that match a given (and every given) O-D pair without using a SQL query (which, if used in a loop, would take forever....). If I can get the rows in some sort of data structure, then I can iterate and find all the routes.

Thus, my question to you is, how would I create a loop that pulls all rows given each O-D pair? Thanks in advance!

Answer 1

Here's how I would do it. Create a custom class module named 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

Then create a custom class module named 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

And finally, create a standard module with this in it

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

You can download an example workbook here http://dailydoseofexcel.com/excel/Routes.xlsm

Answer 2

I'm not sure if this is the answer you're looking for, but maybe it will be a starting point, if I'm understanding you correctly. This routine assumes data starts at "A1", filters and selects the pertinent rows. Sort of a "demo", but perhaps will assist you in the area that's "tripping" you up.

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