Yesterday I created a matrix with arrays. I didn’t love the code and hoped to make something more manageable. Since I sorted the array two different ways, I thought a disconnected recordset might help clean up the code.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
Sub MakeDynamicADO() Dim rs As ADODB.Recordset, rsFilter As ADODB.Recordset Dim rCell As Range Dim colUnique As Collection Dim vItm As Variant Dim lRow As Long Dim rRow As Range, rCol As Range, rFound As Range Application.EnableEvents = False wshMatrix.UsedRange.Clear Set rs = New ADODB.Recordset 'Fill disconnected recordset With rs .Fields.Append "Developer", adVarChar, 50 .Fields.Append "Task", adVarChar, 5 .Fields.Append "File", adVarChar, 1 .CursorLocation = adUseClient .CursorType = adOpenStatic .Open End With For Each rCell In wshData.Range("A2:A16").Cells rs.AddNew rs.Fields("Developer").Value = rCell.Value rs.Fields("Task").Value = rCell.Offset(0, 1).Value rs.Fields("File").Value = rCell.Offset(0, 2).Value rs.Update Next rCell rs.Sort = "Task ASC" 'Get a unique list of dev+task Set colUnique = New Collection With rs .MoveFirst Do While Not .EOF On Error Resume Next colUnique.Add .AbsolutePosition - 1, .Fields("Developer").Value & .Fields("Task").Value On Error GoTo 0 .MoveNext Loop End With 'create matrix headers lRow = 3 For Each vItm In colUnique rs.MoveFirst rs.Move vItm wshMatrix.Cells(lRow, 1).Value = rs.Fields("Developer").Value wshMatrix.Cells(lRow, 2).Value = rs.Fields("Task").Value wshMatrix.Cells(1, lRow).Value = rs.Fields("Developer").Value wshMatrix.Cells(2, lRow).Value = rs.Fields("Task").Value wshMatrix.Cells(lRow, lRow).Interior.Color = RGB(150, 150, 150) lRow = lRow + 1 Next vItm rs.Sort = "File ASC" rs.MoveFirst 'loop through the recordset Do 'clone the recordset and filter the clone on the File Set rsFilter = rs.Clone rsFilter.Filter = "File='" & rs.Fields("File").Value & "'" 'Loop through the clone Do 'Only look forward so no double processing If rsFilter.Bookmark > rs.Bookmark Then Set rRow = wshMatrix.Columns(2).Find(rs.Fields("Task").Value, , xlValues, xlWhole) Set rCol = wshMatrix.Rows(2).Find(rsFilter.Fields("Task").Value, , xlValues, xlWhole) If Not (rRow Is Nothing Or rCol Is Nothing) Then Set rFound = Intersect(rRow.EntireRow, rCol.EntireColumn) If Len(rFound.Value) > 0 Then rFound.Value = rFound.Value & ", " & rs.Fields("File").Value Else rFound.Value = rs.Fields("File").Value End If End If Set rRow = wshMatrix.Columns(2).Find(rsFilter.Fields("Task").Value, , xlValues, xlWhole) Set rCol = wshMatrix.Rows(2).Find(rs.Fields("Task").Value, , xlValues, xlWhole) If Not (rRow Is Nothing Or rCol Is Nothing) Then Set rFound = Intersect(rRow.EntireRow, rCol.EntireColumn) If Len(rFound.Value) > 0 Then rFound.Value = rFound.Value & ", " & rs.Fields("File").Value Else rFound.Value = rs.Fields("File").Value End If End If End If rsFilter.MoveNext Loop Until rsFilter.EOF rs.MoveNext Loop Until rs.EOF rs.Close Application.EnableEvents = True End Sub |
Of course I had to add code to create the recordset and and fill it, but I got rid of the sorting code. That and a few other changes leaves me with code that I still don’t love. Maybe I’m just being picky. I know how to love it though. Classes. I’ll hide some code in class modules and all will be right with the world. That is, unless you come up with something better and put it in the comments.
Great example to learn from. How come there’s a block of code that repeats under the “Loop through the clone” section?
Sean: The file letter goes in two spots. In the first block rRow goes with rs and rCol goes with rsFilter. In the second block, that’s switched.
DK: Assuming the results are symmetric…
You never need to find the row and column a 2nd time. Define the matrix as having element (1,1) at the first grey cell and element (10,10) as the last grey cell. Then, if you have some value that goes in element (r,c), the same result will also be in element (c,r).
Tushar, you are right. They are symmetric. I fixed my code to reflect that.
I probably would have used classes too but I just threw this together just because I like dictionaries. Not entirely elegant but I had fun throwing it together.
Dim i As Integer, j As Integer
Dim saMatrix() As String, saHeader() As String, saFile() As String
Dim sFile As String, sTaskDeveloper As String
Dim rData As Range
Dim vData As Variant
Dim dicTask As Dictionary
‘Initialize variables
Set dicTask = New Dictionary
‘Get sorted data
Set rData = ActiveSheet.UsedRange
Set rData = rData.Offset(1).Resize(rData.Rows.Count – 1)
rData.Sort Key1:=rData.Range(“$B$1”), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
vData = rData
rData.Sort Key1:=rData.Range(“$C$1”), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
‘Organize data
For i = 1 To UBound(vData)
sTaskDeveloper = vData(i, 2) & “:” & vData(i, 1)
sFile = vData(i, 3)
If Not dicTask.Exists(sTaskDeveloper) Then
ReDim saFile(0 To 0)
saFile(0) = sFile
dicTask.Add sTaskDeveloper, saFile
Else
If Not InArray(dicTask(sTaskDeveloper), sFile) Then
saFile = dicTask(sTaskDeveloper)
ReDim Preserve saFile(0 To UBound(saFile) + 1)
saFile(UBound(saFile)) = sFile
dicTask(sTaskDeveloper) = saFile
End If
End If
Next i
‘————————–
‘Organize data for printing
‘————————–
ReDim saMatrix(1 To dicTask.Count + 2, 1 To dicTask.Count + 2)
‘Headers
For i = 3 To dicTask.Count + 2
saHeader = Split(dicTask.Keys(i – 3), “:”)
saMatrix(i, 1) = saHeader(1)
saMatrix(i, 2) = saHeader(0)
saMatrix(1, i) = saHeader(1)
saMatrix(2, i) = saHeader(0)
Next i
‘Add data
For i = 3 To dicTask.Count + 2
For j = 3 To dicTask.Count + 2
If i > j Then
sFile = FilesIntersect(dicTask.Items(i – 3), dicTask.Items(j – 3))
If Len(sFile) > 0 Then
saMatrix(i, j) = sFile
saMatrix(j, i) = sFile
End If
End If
Next j
Next i
‘Print data
rData.Resize(UBound(saMatrix, 1), UBound(saMatrix, 2)).Offset(, rData.Column + 3) = saMatrix
‘Clean up
Set dicTask = Nothing: Set vData = Nothing
Erase saMatrix: Erase saFile
End Sub
Private Function FilesIntersect(ByVal vFile1 As Variant, ByVal vFile2 As Variant) As String
Dim i As Integer, j As Integer
Dim saFile() As String, sTemp As String
ReDim saFile(0 To 0)
‘Delete any repetitions and sort
For i = 0 To UBound(vFile1)
For j = 0 To UBound(vFile2)
If vFile1(i) = vFile2(j) Then
If Len(saFile(0)) > 0 Then
ReDim Preserve saFile(0 To UBound(saFile) + 1)
saFile(UBound(saFile)) = vFile1(i)
Else
saFile(0) = vFile1(i)
End If
End If
Next j
Next i
‘Sort
If Len(saFile(0)) > 0 Then
For i = 0 To UBound(saFile) – 1
For j = 1 To UBound(saFile)
If saFile(i) > saFile(j) Then
sTemp = saFile(j)
saFile(j) = saFile(i)
saFile(i) = sTemp
End If
Next j
Next i
FilesIntersect = Join(saFile, “,”)
Else
FilesIntersect = vbNullString
End If
End Function
Private Function InArray(ByVal vArray As Variant, ByVal sStr As String) As Boolean
Dim i As Integer
InArray = False
For i = 0 To UBound(vArray)
If sStr = vArray(i) Then
InArray = True
Exit For
End If
Next i
Set vArray = Nothing
End Function
[…] I thought a disconnected recordset might help clean up the code. Sub MakeDynamicADO() … [full post] Dick Kusleika Daily Dose of Excel vba 0 0 0 0 0 […]
To filter the unique records with their data you need only 2 lines: (based on the ‘Matrix with Arrays’ example)
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)
Cells(20, 1).Resize(UBound(sq) + 1) = Application.Transpose(sq)
End Sub
[…] A few days ago, Kusleika posted an article that showed how to code a Dynamic Matrix in Excel. He later came back with code to achieve a matrix using ADO. […]