Excel VBA crea informe con valores agrupados

Intento crear un informe en Excel usando VBA para procesar algunos datos y crear un informe tabular que resume los valores por grupo. Aunque puedo generar la tabla manualmente, no puedo get el código para crear completamente este informe.

Datos de input:

ID | name | number | class | comment ---|--------|--------|-------|---------- 1 | john | 4 | A1 | sports ---|--------|--------|-------|---------- 1 | john | 3 | A2 | sports ---|--------|--------|-------|---------- 1 | john | 5 | A3 | sports ---|--------|--------|-------|---------- 2 | charly | 1 | B3 | tech ---|--------|--------|-------|---------- 2 | charly | 2 | B2 | tech ---|--------|--------|-------|---------- 2 | charly | 1 | B2 | tech ---|--------|--------|-------|---------- 3 | frank | 7 | C3 | language ---|--------|--------|-------|---------- 3 | frank | 2 | C5 | language ---|--------|--------|-------|---------- 3 | frank | 9 | C4 | language 

Resumen esperado en una nueva hoja de trabajo:

 ID | name | number | class | comment ---|--------|---------|------------|---------- 1 | john | ”3,4,5” | ”A1,A2,A3” | sports ---|--------|---------|------------|---------- 2 | charly | ”1,2” | ”B2,B3” | tech ---|--------|---------|------------|---------- 3 | frank | ”2,7,9” | ”C3,C4,C5” | language 

Aquí está el código que tengo actualmente:

 Function Uniques(r As Range) Dim d As Object, c As Range, tmp Set d = CreateObject("scripting.dictionary") For Each c In rCells tmp = Trim(c.Value) If Len(tmp) > 0 Then If Not d.Exists(tmp) And tmp <> “HEADER” Then d.Add tmp, 1 End If Next c Uniques = d.keysEnd Function With .Range("A1:N" & .Cells(.Rows.Count, 1).End(xlUp).Row) .AutoFilter Field:=1 Set a = .Columns(“A”).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) Set b = .Columns(“B”).Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) 'getting the unique items d = Uniques(Range("D:D").SpecialCells(xlCellTypeVisible)) .AutoFilter End With 

El enfoque para usar el dictionary es un paso en la dirección correcta, aunque necesita 1 más de ese object de dictionary para usarlo en los loops secundarios. Se vuelve un poco complejo e interesante debido a las columnas adicionales y los requisitos de los datos únicos y orderados como se indica en la porción de resumen esperado en la pregunta.

El siguiente código actualizado supone que la macro se desencadena a partir de la hoja que contiene estos datos y genera el resultado en la Hoja (2):

 Sub strSplit() Dim r As Range, lastRow As Long, k As Variant, k1 As Variant, d As Object, d1 As Object, i As Long, j As Long, cmnt As String Set d = CreateObject("Scripting.Dictionary") Set d1 = CreateObject("Scripting.Dictionary") lastRow = Cells(Rows.Count, 1).End(xlUp).Row For Each r In Range("B2:B" & lastRow) If Not IsEmpty(r) Then d(r.Value) = r.Offset(0, -1).Value Next For Each k In d.Keys i = i + 1 Sheets(2).Cells(i + 1, 1) = d(k) Sheets(2).Cells(i + 1, 2) = k 'get list of unique numbers for each ID + comment For Each r In Range("B2:B" & lastRow) If k = r.Value Then d1(r.Offset(0, 1).Value) = r.Value cmnt = r.Offset(0, 3).Value End If Next j = 0 For Each k1 In d1.Keys If j = 0 Then Sheets(2).Cells(i + 1, 5) = cmnt Sheets(2).Cells(j + d.Count + 2, 3) = k1 j = j + 1 Next Set r = Sheets(2).Range("C" & d.Count + 2 & ":C" & j + 1 + d.Count) r.Sort r.Columns(1) Sheets(2).Cells(i + 1, 3) = colToRw(r) r.ClearContents d1.RemoveAll 'get list of unique classes for each ID For Each r In Range("B2:B" & lastRow) If k = r.Value Then d1(r.Offset(0, 2).Value) = r.Value Next j = 0 For Each k1 In d1.Keys Sheets(2).Cells(j + d.Count + 2, 4) = k1 j = j + 1 Next Set r = Sheets(2).Range("D" & d.Count + 2 & ":D" & j + 1 + d.Count) r.Sort r.Columns(1) Sheets(2).Cells(i + 1, 4) = colToRw(r) r.ClearContents d1.RemoveAll Next Sheets(2).Select End Sub Function colToRw(r As Range) As String Dim r1 As Range, is1st As Boolean is1st = True For Each r1 In r If Not is1st Then colToRw = colToRw & ", " Else: is1st = False End If colToRw = colToRw & r1.Value Next End Function 

versión:

Con base en la discusión posterior, aquí hay una versión modificada y más ligera con un enfoque más funcional. Bajo este enfoque, la columna que necesita ser buscada para una list orderada y única, se puede establecer en la llamada funcional.

 Sub strSplit() Dim r As Range, lastRow As Long, rng As Range, k As Variant, d As Object, i As Long Set d = CreateObject("Scripting.Dictionary") lastRow = Cells(Rows.Count, 1).End(xlUp).Row Set rng = Range("B2:B" & lastRow) For Each r In rng If Not IsEmpty(r) Then d(r.Value) = r.Offset(0, -1).Value Next For Each k In d.Keys i = i + 1 Sheets(2).Cells(i + 1, 1) = d(k) 'column 1 Sheets(2).Cells(i + 1, 2) = k 'column 2 For Each r In rng If k = r.Value Then Sheets(2).Cells(i + 1, 5) = r.Offset(0, 3).Value 'column 5 Exit For End If Next Sheets(2).Cells(i + 1, 3) = uniqNsort(k, rng, 1, d.Count) 'column 3 Sheets(2).Cells(i + 1, 4) = uniqNsort(k, rng, 2, d.Count) 'column 4 Next Sheets(2).Select End Sub Function uniqNsort(k, rng As Range, rngOffsetCol As Long, rwNo As Long) As String 'get ordenetworking list of unique items Dim k1, r As Range, i As Long, d As Object Set d = CreateObject("Scripting.Dictionary") For Each r In rng If k = r.Value Then d(r.Offset(0, rngOffsetCol).Value) = r.Value End If Next For Each k1 In d.Keys Sheets(2).Cells(i + rwNo + 2, 1) = k1 i = i + 1 Next Set r = Sheets(2).Range("A" & rwNo + 2 & ":A" & rwNo + i + 1) r.Sort r.Columns(1) uniqNsort = colToRw(r) r.ClearContents End Function Function colToRw(r As Range) As String Dim r1 As Range, is1st As Boolean is1st = True For Each r1 In r If Not is1st Then colToRw = colToRw & ", " Else: is1st = False End If colToRw = colToRw & r1.Value Next End Function