A friend of mine asked me to turn this
A | B | C | |
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.
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 |
Sub MakeMatrix() Dim rCell As Range Dim vData As Variant Dim colUnique As Collection Dim vItm As Variant Dim lRow As Long Dim i As Long, j As Long Dim rRow As Range, rCol As Range Dim rFound As Range Set colUnique = New Collection wshMatrix.UsedRange.Clear 'Load data into array and sort it on the second column vData = wshData.Range("A2", wshData.Range("A2").End(xlDown)).Resize(, 3).Value SortData vData, 2 'Get unique dev/task combo For i = LBound(vData, 1) To UBound(vData, 1) On Error Resume Next colUnique.Add i, CStr(vData(i, 1) & vData(i, 2)) On Error GoTo 0 Next i 'create matrix headers lRow = 3 For Each vItm In colUnique wshMatrix.Cells(lRow, 1).Value = vData(vItm, 1) wshMatrix.Cells(lRow, 2).Value = vData(vItm, 2) wshMatrix.Cells(1, lRow).Value = vData(vItm, 1) wshMatrix.Cells(2, lRow).Value = vData(vItm, 2) wshMatrix.Cells(lRow, lRow).Interior.Color = RGB(150, 150, 150) lRow = lRow + 1 Next vItm 'resort data on column 3 SortData vData, 3 'get unique list of files Set colUnique = New Collection For i = LBound(vData, 1) To UBound(vData, 1) On Error Resume Next colUnique.Add vData(i, 3), CStr(vData(i, 3)) On Error GoTo 0 Next i 'fill in matrix body For Each vItm In colUnique For i = LBound(vData, 1) To UBound(vData, 1) If vData(i, 3) = vItm Then For j = i + 1 To UBound(vData, 1) If vData(j, 3) = vItm Then Set rRow = wshMatrix.Columns(2).Find(vData(i, 2), , xlValues, xlWhole) Set rCol = wshMatrix.Rows(2).Find(vData(j, 2), , 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 & ", " & vItm Else rFound.Value = vItm End If End If Set rRow = wshMatrix.Columns(2).Find(vData(j, 2), , xlValues, xlWhole) Set rCol = wshMatrix.Rows(2).Find(vData(i, 2), , 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 & ", " & vItm Else rFound.Value = vItm End If End If End If Next j End If Next i Next vItm wshMatrix.Activate End Sub |
Kind of makes you feel dirty, doesn’t it? Well that’s not all. There’s still the matter of the sorting.
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 |
Sub SortData(vData As Variant, lDim As Long) Dim i As Long Dim j As Long Dim vTempName As Variant Dim vTempTask As Variant Dim vTempFile As Variant For i = 1 To UBound(vData, 1) - 1 For j = i To UBound(vData, 1) If vData(i, lDim) > vData(j, lDim) Then vTempName = vData(i, 1) vTempTask = vData(i, 2) vTempFile = vData(i, 3) vData(i, 1) = vData(j, 1) vData(i, 2) = vData(j, 2) vData(i, 3) = vData(j, 3) vData(j, 1) = vTempName vData(j, 2) = vTempTask vData(j, 3) = vTempFile End If Next j Next i End Sub |
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.
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?
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.
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:
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…
‘ 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
.Delete
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
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. :)
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
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
Next
End With
Set objTasks = objTasks.IndexByOrder()
With wksMatrix
.Cells.Delete
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
Next
Next
Next
End With
End Sub
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).
j=i+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)
j++
loop
next i
The code below implements my suggestion of having Excel do all the hard work.
Function RangeDown(StartCell As Range) As Range
Set RangeDown = Range(StartCell, StartCell.End(xlDown))
End Function
Sub createUniqueList(S1 As Worksheet)
With S1
.Range(“g1”).CurrentRegion.Clear
RangeDown(.Range(“A1”)).Resize(, 2) _
.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Range(“G1”), Unique:=True
.Sort.SortFields.Clear
.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
.Apply
End With
End With
End Sub
Sub createMatrix(ByVal S1 As Worksheet, S3 As Worksheet)
With S3
.Cells.Clear
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.Clear
.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
.Apply
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
Loop
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
[…] 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 […]
I managed to get the same result as Dick’s Using:
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
Else
sn(x – 1, y – 1) = sn(x – 1, y – 1) & “,” & sq(j, 3)
End If
c01 = sq(j, 1) & sq(j, 2)
Next
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
Next
Next
sn(j, j) = “”
Next
Cells(20, 1).Resize(UBound(sn), UBound(sn, 2)) = sn
End Sub
Or even simpler:
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
Next
Next
Next
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
Impressive, as usual, hans.
Hans, that’s very creative.
Have you ever visited ioccc.org?
[…] 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 […]