Macro de Excel para eliminar duplicados y resumir detalle

Detalle cabeza de la tropa clon

Hay que normalizar una tabla en Excel mediante macros. La tarea a realizar se divide en los siguientes pasos:

  1. Ordenar las filas
  2. Eliminar las filas consecutivas que estén duplicadas
  3. Resumir las filas agrupando el detalle

Ejemplo

Tabla ordenada

SecciónCategoría Código
PrimeraAlfaA
PrimeraAlfaA
PrimeraAlfaA
PrimeraAlfaB
PrimeraAlfaB
PrimeraAlfaC
SegundaBetaA
SegundaBetaB
SegundaBetaB
SegundaBetaB
TerceraGammaA
TerceraGammaB
TerceraGammaC
TerceraGammaC
CuartaDeltaA
QuintaEpsilonA
QuintaEpsilonB

Sin duplicados

SecciónCategoríaCódigo
PrimeraAlfaA
PrimeraAlfaB
PrimeraAlfaC
SegundaBetaA
SegundaBetaB
TerceraGammaA
TerceraGammaB
TerceraGammaC
CuartaDeltaA
QuintaEpsilonA
QuintaEpsilonB

Detalle resumido

SecciónCategoríaCódigo
PrimeraAlfaA, B, C
SegundaBetaA, B
TerceraGammaA, B, C
CuartaDeltaA
QuintaEpsilonA, B

 

Código fuente de las macros Visual Basic

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
numColumnas = rango.Columns.Count
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

Sub EliminarDuplicados()
'Elimina filas duplicadas sólo si son consecutivas,

Dim rango As Range
Dim filaAnterior As Range, fila As Range
Dim indice As Integer

Set rango = ActiveCell.CurrentRegion
Set filaAnterior = rango.Rows(1)
indice = 2

Do While indice <= rango.Rows.Count
Set fila = rango.Rows(indice)
If RangosIguales(fila, filaAnterior) Then
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.Value <> celda2.Value Then
RangosIguales = False
Exit Function
End If
Next
RangosIguales = True
End Function

Descargar la hoja de cálculo agrupar_detalle.xls…

Comentarios

  1. 1 Brenda 2009-02-16 Hace 9 años
    Hola ! Estoy tratando de usar esta macro para otro archivo pero estoy teniendo complicaciones.
    Mi archivo original tiene en vez de dos campos iguales, tres campos iguales y necesito agruparlos. En que parte de la secuencia hay que modificar dicho dato.

    Mucahs Gracias,

    Brenda
  2. 2 Eduardo 2011-11-13 Hace 6 años
    Buenas noches Yo tengo esta macro para introducir faltantes en una columna
    Sub Macro_Consecutivo()
    Dim Nro_Fila As Double
    Dim Valor_Celda As Double
    Dim Comienzo_Fila As Double
    Nro_Fila = InputBox("Ingrese el Nro de Fila desde donde se Comenzará a Chequear el Consecutivo", "No de Fila Inicial")
    Comienzo_Fila = Nro_Fila
    Valor_Celda = Range("F" & Nro_Fila).Value 'si no es la columna A cambiar letra
    Do While Val(Range("F" & Nro_Fila).Value) > 0 'si no es la columna A cambiar letra
    If Nro_Fila > Comienzo_Fila Then
    If Val(Range("F" & Nro_Fila).Value) > Valor_Celda Then 'si no es la columna A cambiar letra
    Rows(Nro_Fila & ":" & Nro_Fila).Select
    Selection.Insert shift:=xlDown
    Range("F" & Nro_Fila).Value = Valor_Celda 'si no es la columna A cambiar letra
    End If
    End If
    Nro_Fila = Nro_Fila + 1
    Valor_Celda = Valor_Celda + 1
    Loop
    End Sub
    pero cuando encuentra valores duplicados NO PONE LOS FALTANTES
    me pueden apoyar para que SI lo haga?
Proinf.net, ©2003-2017 ci 3.1.5 (CC) Esta obra está bajo una licencia de Creative Commons Este software está sujeto a la CC-GNU GPL