Macro para Agrupar y sumar datos repetidos en tabla

Hola expertos tengo esta macro que hace lo siguiente(funciona el excel 2010 la macro fue hecha en versión 2003), agrupa y elimina filas repetidas generando al final un resumen. Para que funcione la macro primero indexo la tabla por "categoría" y luego por "cod interno"

codinterno Categoría guía remisión
1220012 - 029-125
1220012 - 029-123
1220012 - 029-124
1220012 CAT2 029-126
1450012 - 029-127
1450012 - 029-129
1450012 CAT2 029-128

El resultado de la macro es el siguiente:

cod interno Categoría guía remisión
1220012 - 029-125, 029-123, 029-124
1220012 CAT2 029-126
1450012 - 029-127, 029-129
1450012 CAT2 029-128

ok de maravilla, el problema que tengo es que quiero agregar mas columnas como este ejemplo:

cod interno Categoría tipo estilo guía remisión transporte empaques peso
1220012 - QW a 029-125 norte 12 322
1220012 - QW a 029-123 norte 3 564
1220012 - QW a 029-124 sur 8 345
1220012 CAT2 QW a 029-126 sur 7 353
1450012 - QR b 029-127 este 13 234
1450012 CAT2 QR b 029-128 este 15 235
1450012 - QR b 029-129 oeste 21 345

y obtener este resultado:

modificando la misma macro

cod interno Categoría tipo estilo guía remisión transporte empaques peso
1220012 - QW a 029-125, 029-123, 029-124 norte,norte, sur 23 1231
1220012 CAT2 QW a 029-126 sur 7 353
1450012 - QR b 029-127, 029-129 este, oeste 34 579
1450012 CAT2 QR b 029-128 este 15 235

Les adjunto la macro

Option Explicit
Sub ResumirDetalle()
'Agrupa filas iguales y resume el detalle
Dim rango As Range
Dim filaAnterior As Range, fila As Range
Dim compararAnterior As Range, comparar As Range
Dim detalleAnterior As Range, detalle As Range
Dim indice As Integer, numColumnas As Integer
Set rango = ActiveCell.CurrentRegion 'si esta una celda seleccionada en la tabla seleeciona toda la region
numColumnas = rango.Columns.Count 'numero de columnas de la tabla seleccionada
Set filaAnterior = rango.Rows(1)
indice = 2
Do While indice <= rango.Rows.Count
Set fila = rango.Rows(indice)
'Obtener todas las celdas de la fila menos la última
Set comparar = fila.Resize(1, numColumnas - 1)
Set compararAnterior = filaAnterior.Resize(1, numColumnas - 1)
If RangosIguales(comparar, compararAnterior) Then
'Consideramos que el detalle es la última celda de la fila
Set detalle = fila.Cells(numColumnas) 'Set detalle = fila.Offset(0, numColumnas - 1).Resize(1, 1)
Set detalleAnterior = filaAnterior.Cells(numColumnas) 'Set detalleAnterior = filaAnterior.Offset(0, numColumnas - 1).Resize(1, 1)
'Agrupar el detalle y borrar la fila
detalleAnterior.Value = detalleAnterior.Value & ", " & detalle.Value
fila.Delete
Else
Set filaAnterior = fila
indice = indice + 1
End If
Loop
End Sub
Function RangosIguales(rango1 As Range, rango2 As Range) As Boolean
'Retorna "true" si los valores de ambos rangos son iguales
Dim indice As Integer
Dim celda1 As Range
Dim celda2 As Range
If rango1.Cells.Count <> rango2.Cells.Count Then
RangosIguales = False
Exit Function
End If
For indice = 1 To rango1.Cells.Count
Set celda1 = rango1.Cells(indice)
Set celda2 = rango2.Cells(indice)
If celda1.Text <> celda2.Text Then
RangosIguales = False
Exit Function
End If
Next
RangosIguales = True
End Function