Dynamic Matrix

A friend of mine asked me to turn this

1 Developer Task # File
2 Evelyn 74333 A
3 Ava 60490 A
4 Carlos 52120 A
5 Andrew 20392 B
6 Andrew 57972 B
7 Andrew 20392 C
8 Payton 29506 C
9 Rachel 25639 D
10 Rachel 14330 D
11 Andrew 51722 E
12 Andrew 20758 E
13 Andrew 51722 F
14 Andrew 20758 F
15 Andrew 51722 G
16 Andrew 20758 G

into this

I busted through the code and, while it works, I’m not very pleased with it. It’s too long and has too many loops. Take a look.

Kind of makes you feel dirty, doesn’t it? Well that’s not all. There’s still the matter of the sorting.

Just a bubble sort there. Nothing fancy. I’m going to make this code better, but not tomorrow. Tomorrow I’m going to use a disconnected recordset and ADO to eliminate the sorting routine. Should be cleaner code, right? Right? You’ll have to wait until tomorrow to see. In the mean time, if you make a nice piece of code to accomplish this task, share it in the comments. Be sure to use code tags.

13 thoughts on “Dynamic Matrix

  1. What is the purpose of the visual display?

    What is the File column?

    The example seems to work out well in having all the data be symmetric. But what if Andrew 51722 had files E and F and Andrew 20758 only had E and F? How would that be shown?

    Or even more complex, if 20758 had E, F, and D?

  2. Thinking on my feet here (well, in the comfy armchair actually) – I think you could condense things somewhat. Create collections for row headers, column headers and the intersections and populate them all in one pass. The intersection key is developer name + task (delimited in some way) and the value is (say) another collection, into which go the file labels. Then you need a collection-sorter, which you apply to the header collections for setting up the output and iterate through both sets to find the cells which have files, which are again sorted by the aforementioned subroutine before being Join()ed. Something like that.

    I’d kind of like to see how the disconnected recordset thing works too, though.

  3. Mike’s answer is probably the way to go…

    You can, of course, go too far: I had the job of replicating a ‘Relation’ object that was widely used in a former client – an array with some indexed columns and an ability to refer to data items by a row label and the column name – and after a year or so it had grown into a monster. Sort functions, filtering, XML export… Any of the functions I wrote were, taken in isolation, worthy and worthwhile things to have; but taken together they amounted to the worst example of bloating since the Hindenburg Disaster.

    I’ll post it here if you ask me nicely.

    Meanwhile, here’s the code for the ‘Dictionary Sort’ and ‘Dictionary to Array’ functions you’ll need for Mike’s solution:

    Option Explicit

    Public Function DictionarySort(InputDictionary As Scripting.Dictionary, Optional Descending As Boolean = False) As Scripting.Dictionary
    ‘ Return a dictionary, sorted by the numerical values of the dictionary items.

    ‘ Nigel Heffernan  May 2008  http://excellerando.blogspot.com/
    ‘ This code is in the public domain

    ‘ External Dependencies:

    ‘ 1:    Reference to ‘Scripting’
    ‘       Microsoft Scripting Runtime
    ‘       C:WINDOWSsystem32scrrun.dll

    ‘ Internal Dependencies:

    ‘ 1:    DictionaryToArray
    ‘       basUtilities.DictionaryToArray
    ‘       Turn a Scripting Dictionary into a two-column array variant: keys in column 1

    ‘ 2:    ArrayToDictionary
    ‘       basUtilities.ArrayToDictionary
    ‘       Collate two columns from an array into a Dictionary object

    ‘ 3:    BubbleSort
    ‘       basUtilities.BubbleSort
    ‘       VBA mplementation of BubbleSort with a parameter to select the sort index column

    On Error Resume Next

    Dim arrDict As Variant

    arrDict = DictionaryToArray(InputDictionary)
    BubbleSort arrDict, UBound(arrDict, 2), Descending

    Set DictionarySort = ArrayToDictionary(arrDict, LBound(arrDict, 2))

    Erase arrDict

    End Function

    Public Sub BubbleSort(ByRef InputArray, Optional SortColumn As Integer = 0, Optional Descending As Boolean = False)
    ‘ Sort a 2-Dimensional array.

    ‘ Nigel Heffernan  March 2008  http://excellerando.blogspot.com/
    ‘ This code is in the public domain

    Dim iFirstRow   As Integer
    Dim iLastRow    As Integer
    Dim iFirstCol   As Integer
    Dim iLastCol    As Integer
    Dim i           As Integer
    Dim j           As Integer
    Dim k           As Integer
    Dim varTemp     As Variant
    Dim OutputArray As Variant

    ‘ CODE REMOVED: ‘ArrayDimensions’ function to implement Vector Array sorting

        iFirstRow = LBound(InputArray, 1)
        iLastRow = UBound(InputArray, 1)

        iFirstCol = LBound(InputArray, 2)
        iLastCol = UBound(InputArray, 2)

        If SortColumn < iFirstCol Then
            SortColumn = iFirstCol
        End If

        For i = iFirstRow To iLastRow – 1
            For j = i + 1 To iLastRow
                If InputArray(i, SortColumn) > InputArray(j, SortColumn) Then
                    For k = iFirstCol To iLastCol
                        varTemp = InputArray(j, k)
                        InputArray(j, k) = InputArray(i, k)
                        InputArray(i, k) = varTemp
                    Next k
                End If
            Next j
        Next i

        If Descending Then

            OutputArray = InputArray

            For i = LBound(InputArray, 1) To UBound(InputArray, 1)

                k = 1 + UBound(InputArray, 1) – i
                For j = LBound(InputArray, 2) To UBound(InputArray, 2)
                    InputArray(i, j) = OutputArray(k, j)
                Next j

            Next i

            Erase OutputArray

        End If

    End Sub

    Public Function DictionaryToArray(InputDictionary As Scripting.Dictionary) As Variant
    ‘ Return a 2-column array consisting of the dictionary’s keys and items
    ‘ Array ordinals are (1 to Dictionary.count, 1 to 2)

    ‘ Nigel Heffernan  Feb 2005  http://excellerando.blogspot.com/
    ‘ This code is in the public domain

    ‘ External Dependencies:

    ‘ 1:    Reference to ‘Scripting’
    ‘       Microsoft Scripting Runtime
    ‘       C:WINDOWSsystem32scrrun.dll

    On Error Resume Next

    Dim iRow    As Long
    Dim iCount  As Long
    Dim arrOutput  As Variant

    Dim arrKeys As Variant
    Dim arrData As Variant

    arrKeys = InputDictionary.Keys
    arrData = InputDictionary.Items
    iCount = InputDictionary.Count

    If iCount = 0 Then
        DictionaryToArray = Empty
        Exit Function
    End If

    ReDim arrOutput(1 To iCount, 1 To 2)

    For iRow = 1 To iCount

        arrOutput(iRow, 1) = arrKeys(iRow – 1)
        arrOutput(iRow, 2) = arrData(iRow – 1)

    Next iRow

    DictionaryToArray = arrOutput

    Erase arrKeys
    Erase arrData

    End Function

    Public Function ArrayToDictionary(InputArray As Variant, _
                                      Optional iKeyColumn As Long = -255, _
                                      Optional iDataColumn As Long = -255 _
                                      ) As Scripting.Dictionary

    ‘ Parse a 2-column array into a dictionary
    ‘ You can specify which columns contain the keys and the data.

    ‘ By default, the leftmost column of the array is used for the dictionary
    ‘ keys, and the rightmost for the data items.  A ‘dummy’ value of -255 is
    ‘ used for missing column specifiers, as it is entirely possible that you
    ‘ will specify column zero;  it would be inconvenient to have this parsed
    ‘ as ‘missing’ parameter and overridden by the left- or rightmost columns

    ‘ Duplicates will be ignored and no error will be raised: you are advised
    ‘ to check the dictionary count against the array dimensions

    ‘ Nigel Heffernan  May 2008   http://excellerando.blogspot.com/
    ‘ This code is in the public domain

    ‘ External Dependencies:

    ‘ 1:    Reference to ‘Scripting’
    ‘       Microsoft Scripting Runtime
    ‘       C:WINDOWSsystem32scrrun.dll

    On Error Resume Next

    Dim iRow    As Long
    Dim strKey  As String

    If IsEmpty(InputArray) Then
        Exit Function
    End If

    Set ArrayToDictionary = New Scripting.Dictionary

    If iKeyColumn = -255 Then
        iKeyColumn = LBound(InputArray, 2)
    End If

    If iDataColumn = -255 Then
        iDataColumn = UBound(InputArray, 2)
    End If

    For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)

        strKey = “”
        strKey = InputArray(iRow, iKeyColumn)

        If strKey <> “” Then

            If Not ArrayToDictionary.Exists(strKey) Then

                ArrayToDictionary.Add strKey, InputArray(iRow, iDataColumn)

            End If ‘ Not exists

        End If ‘strKey <> “”

    Next iRow

    End Function

    And, as evidence of testing and a demonstration that this stuff has some practical use: decluttering the CommandBar area – a common problem in companies with a plethora of Add-Ins, each of which places its own menu in a new row in thr ‘header’ area of the Application window. Yes, there’s got to be a more efficient way of doing this, but I used the code that was lying around…

    Public Sub TidyCommandBars()
    ‘ Closes-up unused vertical and horizontal space between CommandBars
    ‘ in the ‘msoBarTop’ menubar docking area of the application window.

    ‘ Additional code will be required to do this for Menubars

    ‘ Nigel Heffernan  Dec 2010  http://excellerando.blogspot.com/
    ‘ This code is in the public domain

    ‘ External Dependencies:

    ‘ 1:    Reference to ‘Office’
    ‘       Microsoft Office 11.0 Object Library
    ‘       C:Program FilesCommon FilesMicrosoft SharedOFFICE11MSO.DLL

    ‘ 2:    Reference to ‘Scripting’
    ‘       Microsoft Scripting Runtime
    ‘       C:WINDOWSsystem32scrrun.dll

    ‘ Internal Dependencies:

    ‘ 1:    DictionarySort
    ‘       basUtilities.DictionarySort
    ‘       Simple macro to sort a Scripting Dictionary by its items’ values

    On Error Resume Next

    Dim objCbar         As Office.CommandBar
    Dim dictCbarTops    As Scripting.Dictionary
    Dim dblNextLeft     As Double
    Dim dblNextTop      As Double
    Dim dblEndRight     As Long
    Dim i               As Integer
    Dim strName         As String

    Application.ScreenUpdating = False

    Set dictCbarTops = New Scripting.Dictionary

    ‘ Measure the width of the space available for commandBars:

    ‘   dblEndRight = Application.UsableWidth

    ‘ Application.UsableWidth can sometimes give the width of the largest window
    ‘ in the mdi frame. This is less than the available area for commandbars, so
    ‘ we need to hack a usable measure of the command bar area’s usable width…

    With Application.CommandBars.Add
        .Visible = False
        .Position = msoBarTop
        .Left = 10000   ‘ this places the object offscreen to the right
        .Visible = True ‘ places the offscreen object at the rightmost available location
         dblEndRight = .Left + .Width
        .Visible = False
    End With

    ‘ List the visible CommandBars by name and vertical position:
    For Each objCbar In Application.CommandBars
        With objCbar
            If .Visible And .Type = msoBarTypeNormal And .Position = msoBarTop Then
                 ‘Debug.Print objCbar.Top & “,” & objCbar.Left & vbTab & objCbar.Name
                dictCbarTops.Add .Name, .Top
            End If
        End With
    Next objCbar

    If dictCbarTops.Count < 1 Then
        Exit Sub
    End If

    ‘ Sort the dictionary by vertical position:
    Set dictCbarTops = DictionarySort(dictCbarTops)

    dblNextTop = dictCbarTops.Items(0)
    dblNextLeft = 0

    ‘ Loop through the list, repositioning them as necessary:
    For i = 0 To dictCbarTops.Count – 1

        strName = dictCbarTops.Keys(i)
        Set objCbar = Application.CommandBars(strName)
         ‘Debug.Print objCbar.Top & “,” & objCbar.Left & vbTab & objCbar.Name
        If dblNextLeft + objCbar.Width > dblEndRight Then
             ‘ start a new row of CommandBars
            dblNextTop = dblNextTop + objCbar.Height
            dblNextLeft = 0
        End If
        If dblNextLeft <> objCbar.Left Then
            objCbar.Left = dblNextLeft
             ‘Debug.Print vbTab & “Repositioned ” & objCbar.Name & vbTab & objCbar.Top & “,” & objCbar.Left
        End If
        If dblNextTop < objCbar.Top Then
             ‘ If you try to set the .Top property, the RowIndex property immediately
             ‘ overrides your specified value for .Top and repositions the CommandBar.
             ‘ You must therefore specify the .RowIndex
            If i > 0 Then
                strName = dictCbarTops.Keys(i – 1)
                objCbar.RowIndex = Application.CommandBars(strName).RowIndex
                 ‘Debug.Print vbTab & “Repositioned ” & objCbar.Name & vbTab & objCbar.Top & “,” & objCbar.Left
            End If
        End If
        dblNextLeft = dblNextLeft + objCbar.Width
        Set objCbar = Nothing
    Next i

    Set dictCbarTops = Nothing

    Application.ScreenUpdating = True

    End Sub

  4. I don’t know what any of the data actually means. I just got the before and after and was asked to supply the middle. It was a free one for a friend. I only ask questions when they pay me. :)

  5. I had a go using custom collections…
    It wasn’t any shorter as a whole (in fact, it was a lot longer), but the core routine was concise.

    The problem was difficult because it deals with a many-to-many relationship (task to file).
    I made the assumption that task number a key column, and that two developers couldn’t be assigned the same task number.

    download xlsm file here

    Sub MakeRobMatrix()
        Const cFirstRow = 2, cOvhd = 2
        Const cDeveloperCol = 1, cTaskCol = 2, cFileCol = 3
        Const cDeveloperPos = 1, cTaskPos = 2
        Const cInteriorColor = &H969696 ‘ RGB(150, 150, 150)

        Dim objFiles As Files, fil As File
        Dim objTasks As Tasks, tsk As Task, tsk2 As Task
        Dim i As Long, str As String

        Set objFiles = New Files
        Set objTasks = New Tasks

        With wksData
            For i = cFirstRow To .Cells(Rows.Count, 1).End(xlUp).Row
                Set fil = objFiles.AddNewUnique(.Cells(i, cFileCol))
                Set tsk = objTasks.AddNewUnique(.Cells(i, cTaskCol), .Cells(i, cDeveloperCol))
                tsk.Files.Add fil
                fil.Tasks.Add tsk
        End With

        Set objTasks = objTasks.IndexByOrder()

        With wksMatrix

            For i = 1 To objTasks.Count
                Set tsk = objTasks(i)
                .Cells(i + cOvhd, cDeveloperPos) = tsk.Developer
                .Cells(i + cOvhd, cTaskPos) = tsk.Task
                .Cells(cDeveloperPos, i + cOvhd) = tsk.Developer
                .Cells(cTaskPos, i + cOvhd) = tsk.Task
                .Cells(i + cOvhd, i + cOvhd).Interior.Color = cInteriorColor

                For Each fil In tsk.Files
                    For Each tsk2 In fil.Tasks
                        If tsk2.Task <> tsk.Task Then
                            With .Cells(i + cOvhd, tsk2.Index + cOvhd)
                                .Value = .Value & IIf(.Value = “”, “”, “, “) & fil.FileName
                            End With
                        End If
        End With

    End Sub

  6. You can have Excel do almost all of this with VBA just ‘guiding’ Excel along. Part of this ‘guiding’ is to adapt the range references to an initial data set of different sizes.

    Suppose the original data are in Sheet1 starting with A2 and extending to N rows. This means that row 1 is a header row.

    1) Use Advanced Filter to create a unique list of Dev and Task. Sort by Task ascending.

    2) Copy this list to some sheet (say Sheet3) starting with A3 and also copy transpose it to the same sheet starting with C1.

    3) Use CF in the region formed by 2 so that if row()=column() then the cell has a gray fill

    4) Resort the original data on File ascending and Task ascending

    5) For each entry in sheet1 add the matrix row number in Sheet3 of the same entry. So, in D2 enter the formula =MATCH(B2,Sheet3!$B$3:$B$12,0) — adjust the formula to pick up the correct number of rows in sheet3. Copy D2 as far down as needed.

    6) This last piece is the only one that requires logic in the code (and that too only because I don’t know how to do a multiple concatenate with a formula).

    for i=2 to N-1
        do while j< = N and c{j}=c{i}
            add sheet1.c{i} to sheet3.cells(sheet1.d{i}+2,sheet1.d{j}+2) and to sheet3.cells(sheet1.d{j}+2,sheet1.d{i}+2)
        next i
  7. The code below implements my suggestion of having Excel do all the hard work.

    Option Explicit
    Function RangeDown(StartCell As Range) As Range
        Set RangeDown = Range(StartCell, StartCell.End(xlDown))
        End Function

    Sub createUniqueList(S1 As Worksheet)
        With S1
        RangeDown(.Range(“A1”)).Resize(, 2) _
            .AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=.Range(“G1”), Unique:=True
        .Sort.SortFields.Add Key:=RangeDown(.Range(“H2”)) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange RangeDown(S1.Range(“G1”)).Resize(, 2)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            End With
            End With
        End Sub
    Sub createMatrix(ByVal S1 As Worksheet, S3 As Worksheet)
        With S3
        RangeDown(S1.Range(“G2”)).Resize(, 2).Copy
        .Range(“A3”).PasteSpecial Paste:=xlPasteAll
        .Range(“C1”).PasteSpecial _
            Paste:=xlPasteAll, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=True
            End With
        End Sub
    Sub createGreyDiagonal(S3 As Worksheet)
        With S3
        Dim I As Integer
        For I = 3 To .Range(“a3”).End(xlDown).Row
            With .Cells(I, I).Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = -4.99893185216834E-02
            .PatternTintAndShade = 0
                End With
            Next I
            End With

        End Sub
    Sub sortSourceByFile(ByRef S1 As Worksheet)
        With S1
        .Sort.SortFields.Add Key:=RangeDown(.Range(“C2”)) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add Key:=RangeDown(.Range(“B2”)) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets(“Sheet1”).Sort
            .SetRange RangeDown(S1.Range(“A1”)).Resize(, 3)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            End With
            End With
        End Sub
    Sub addMatchFormula(ByRef S1 As Worksheet, ByVal S3 As Worksheet)
        RangeDown(S1.Range(“D2”)).FormulaR1C1 = _
            “=MATCH(RC[-2],” _
            & RangeDown(S3.Cells(3, 2)).Address(True, True, xlR1C1, True) _
            & “,0)”
        End Sub
        Function doConcatenate(ByVal FileID As String, _
                ByVal CurrVal As String)
            doConcatenate = IIf(CurrVal = “”, _
                FileID, CurrVal & “,” & FileID)
            End Function
    Sub addElement(ByVal FileID As String, ByRef S3 As Worksheet, _
            ByVal I As Integer, ByVal J As Integer)
        S3.Cells(I + 2, J + 2).Value = _
            doConcatenate(FileID, S3.Cells(I + 2, J + 2).Value)
        S3.Cells(J + 2, I + 2).Value = _
            S3.Cells(I + 2, J + 2).Value
        End Sub
    Sub addFileIDsToMatrix(ByVal SrcRng As Range, ByRef S3 As Worksheet)
        Dim I As Integer
        For I = 1 To SrcRng.Rows.Count – 1
            Dim FileID As String
            FileID = SrcRng.Cells(I, 1).Offset(0, -1).Value
            Dim J As Integer
            J = I + 1
            Do While J <= SrcRng.Rows.Count _
                    And FileID _
                        = SrcRng.Cells(J, 1).Offset(0, -1).Value
                addElement FileID, S3, _
                    SrcRng.Cells(I, 1).Value, SrcRng.Cells(J, 1).Value
                J = J + 1
            Next I
        End Sub
    Sub buildMatrix()
        Dim S1 As Worksheet, S3 As Worksheet
        Set S1 = ActiveWorkbook.Worksheets(“sheet1”)
        Set S3 = ActiveWorkbook.Worksheets(“sheet3”)
        ‘S1 is the source worksheet.  Assumptions: _
         Data start in A1 and row 1 is a header _
         The region around G1 has no data _
         S3 is the destination worksheet and can be _
         cleared as required
       createUniqueList S1
        createMatrix S1, S3
        createGreyDiagonal S3
        sortSourceByFile S1
        addMatchFormula S1, S3
        addFileIDsToMatrix RangeDown(S1.Cells(2, 4)), S3
        End Sub

  8. […] 57972 B 7 Andrew 20392 C 8 Payton 29506 C 9 Rachel 25639 D 10 Rachel 14330 D 11 Andrew 51722 E… [full post] Dick Kusleika Daily Dose of Excel vba 0 0 0 0 0 […]

  9. I managed to get the same result as Dick’s Using:

    Sub tst()
      Cells(1).CurrentRegion.Sort Cells(1).Offset(, 1)
      sq = Cells(1).CurrentRegion
      sn = Cells(1).CurrentRegion.Offset(UBound(sq)).Resize(UBound(sq) + 2, UBound(sq) + 2)
      x = 3
      y = 3
      For j = 1 To UBound(sq)
        If c01 <> sq(j, 1) & sq(j, 2) Then
          sn(1, x) = sq(j, 1)
          sn(2, x) = sq(j, 2)
          sn(y, 1) = sq(j, 1)
          sn(y, 2) = sq(j, 2)
          sn(x, y) = sq(j, 3)
          x = x + 1
          y = y + 1
          sn(x – 1, y – 1) = sn(x – 1, y – 1) & “,” & sq(j, 3)
        End If
        c01 = sq(j, 1) & sq(j, 2)
      For j = 3 To UBound(sn, 2)
        st = Split(sn(j, j), “,”)
        For jj = 0 To UBound(st)
          For jjj = j + 1 To UBound(sn, 2)
            If InStr(sn(jjj, jjj), st(jj)) > 0 Then
              sn(j, jjj) = IIf(sn(j, jjj) = “”, “”, sn(j, jjj) & “,”) & st(jj)
              sn(jjj, j) = IIf(sn(jjj, j) = “”, “”, sn(jjj, j) & “,”) & st(jj)
            End If
        sn(j, j) = “”
      Cells(20, 1).Resize(UBound(sn), UBound(sn, 2)) = sn
    End Sub
  10. Or even simpler:

    Sub tst()
      Cells(1).CurrentRegion.Sort Cells(1).Offset(, 1)

      sq = Split(Replace(Join(Filter([transpose(if(countif(offset($B$1,,,row(B1:B15)),B1:B15)>1,“,” & C1:C15,A1:A15 & “|” & B1:B15&“|” & C1:C15))], “”), vbCr), vbCr & “,”, “,”), vbCr)

      sn = Cells(23, 1).Resize(UBound(sq) + 1, UBound(sq) + 3)
      For j = 0 To UBound(sq)
        sr = Split(sq(j), “|”)
        sn(j + 1, 1) = sr(0)
        sn(j + 1, 2) = sr(1)
        st = Split(sr(2), “,”)
        For Each cl In st
          For jj = j + 1 To UBound(sq)
            If InStr(Split(sq(jj), “|”)(2), cl) > 0 Then
              sn(jj + 1, j + 3) = IIf(sn(jj + 1, j + 3) = “”, “”, sn(jj + 1, j + 3) & “,”) & cl
              sn(j + 1, jj + 3) = sn(jj + 1, j + 3)
            End If
      Cells(23, 1).Resize(UBound(sn), UBound(sn, 2)) = sn
      Cells(21, 3).Resize(2, UBound(sn)) = Application.Transpose(Cells(23, 1).CurrentRegion.Resize(, 2))
    End Sub

Posting code? Use <pre> tags for VBA and <code> tags for inline.

Leave a Reply

Your email address will not be published.