utilizando - excel eliminar duplicados y sumar valores

Excel VBA-Combina filas con valores duplicados en una celda y fusiona valores en otra celda

Question

Estoy tratando de encontrar valores duplicados en una columna y combinar los valores de una segunda columna en una fila. También quiero sumar los valores en una tercera columna.

Por ejemplo:

A    B    C    D
h    4    w    3
h    4    u    5
h    4    g    7
h    4    f    4
k    9    t    6
k    9    o    6
k    9    p    9
k    9    j    1

Se convertiría

A    B    C        D
k    9    t;o;p;j  22
h    4    w;u;g;f  19

El código que he estado usando para la primera parte de esto es

 Sub mergeCategoryValues()
Dim lngRow As Long

With ActiveSheet

lngRow = .Cells(65536, 1).End(xlUp).Row

.Cells(1).CurrentRegion.Sort key1:=.Cells(1), Header:=xlYes 
Do

    If .Cells(lngRow, 9) = .Cells(lngRow + 1, 9) Then
        .Cells(lngRow, 11) = .Cells(lngRow, 8) & "; " & .Cells(lngRow + 1, 8)
        .Rows(lngRow +1).Delete
    End If

    lngRow = lngRow - 1

Loop Until lngRow < 2

End With

End Sub

(por favor perdone la sangría)

El problema con el que me estoy encontrando es que encontrará el primer par de duplicados, pero no todos. Entonces obtengo un resultado que se ve así:

A    B    C    D
k    9    t;o  12
k    9    p;j  10   
h    4    w;u  8
h    4    g;f  11

¿Pensamientos?

Gracias de antemano.

Answer 1

.Cells(lngRow, 11) = .Cells(lngRow, 8) & "; " & .Cells(lngRow + 1, 8)

debiera ser

.Cells(lngRow, 11) = .Cells(lngRow, 8) & "; " & .Cells(lngRow + 1, 11)

Answer 2

Esto se ve descuidado y complicado. Ambos son verdaderos, pero funciona bastante bien. ¡Nota! Siempre recomiendo definir todos los DIM como: rangos, enteros, etc. Almacenar la última fila en una variable como LngRow es mejor (no como toda la App.WksFunc.COUNTA ). También me gusta utilizar las funciones directamente en las celdas cuando sea posible (como las SUMIFS continuación). Por lo tanto, en función de su configuración de ejemplo (columnas ABCD) :

Sub Test_Texas2014()
Dim MySheet As Worksheet: Set MySheet = Sheets("Sheet1")

''Clear the previous results before populating 
MySheet.Range("F:I").Clear

''Step1 Find distinct values on column A and copy them on F
For i = 1 To Application.WorksheetFunction.CountA(MySheet.Range("A:A"))
    Row_PasteCount = Application.WorksheetFunction.CountA(MySheet.Range("F:F")) + 1
    Set LookupID = MySheet.Range("A" & i)
    Set LookupID_SearchRange = MySheet.Range("F:F")
    Set CopyValueID_Paste = MySheet.Range("F" & Row_PasteCount)
        If IsError(Application.Match(LookupID, LookupID_SearchRange, 0)) Then
            LookupID.Copy
            CopyValueID_Paste.PasteSpecial xlPasteValues
        End If
Next i

''Step2 fill your values in columns G H I based on selection
For j = 1 To Application.WorksheetFunction.CountA(MySheet.Range("F:F"))
    Set ID = MySheet.Range("F" & j)
    Set Index = MySheet.Range("G" & j)
    Set AttributeX = MySheet.Range("H" & j)
    Set SumX = MySheet.Range("I" & j)
    For k = 1 To Application.WorksheetFunction.CountA(MySheet.Range("A:A"))
        Set SearchedID = MySheet.Range("A" & k)
        Set SearchedID_Index = MySheet.Range("B" & k)
        Set SearchedID_AttributeX = MySheet.Range("C" & k)
        Set SearchedID_SumX = MySheet.Range("D" & k)
            If ID.Value = SearchedID.Value Then
                Index.Value = SearchedID_Index.Value
                AttributeX.Value = AttributeX.Value & ";" & SearchedID_AttributeX.Value
                SumX.Value = SumX.Value + SearchedID_SumX.Value
            End If
        Next k
    Next j
End Sub

''Although for the sum I would use something like:
MySheet.Range("I1").Formula = "=SUMIFS(D:D,A:A,F1)"
MySheet.Range("I1").Copy
MySheet.Range("I2:I" & Application.WorksheetFunction.CountA(MySheet.Range("I:I"))).pasteSpecial xlPasteFormulas
''Similar for the Index with a Vlookup or Index(Match())

Answer 3

Intenta cambiar tu código a esto:

Sub mergeCategoryValues()
    Dim lngRow As Long

    With ActiveSheet
        lngRow = .Cells(65536, 1).End(xlUp).Row
        .Cells(1).CurrentRegion.Sort key1:=.Cells(1), Header:=xlYes

        Do
            If .Cells(lngRow, 1) = .Cells(lngRow - 1, 1) Then
                .Cells(lngRow - 1, 3) = .Cells(lngRow - 1, 3) & "; " & .Cells(lngRow, 3)
                .Cells(lngRow - 1, 4) = .Cells(lngRow - 1, 4) + .Cells(lngRow, 4)
                .Rows(lngRow).Delete
            End If

            lngRow = lngRow - 1
        Loop Until lngRow = 1
    End With
End Sub

Probado

EDITAR

Para facilitar un poco el ajuste a diferentes columnas, agregué variables al comienzo para indicar qué columna hacer qué. Tenga en cuenta que la columna 2 (B) no se usa en la lógica actual.

Sub mergeCategoryValues()
    Dim lngRow As Long

    With ActiveSheet
        Dim columnToMatch As Integer: columnToMatch = 1
        Dim columnToConcatenate As Integer: columnToConcatenate = 3
        Dim columnToSum As Integer: columnToSum = 4

        lngRow = .Cells(65536, columnToMatch).End(xlUp).Row
        .Cells(columnToMatch).CurrentRegion.Sort key1:=.Cells(columnToMatch), Header:=xlYes

        Do
            If .Cells(lngRow, columnToMatch) = .Cells(lngRow - 1, columnToMatch) Then
                .Cells(lngRow - 1, columnToConcatenate) = .Cells(lngRow - 1, columnToConcatenate) & "; " & .Cells(lngRow, columnToConcatenate)
                .Cells(lngRow - 1, columnToSum) = .Cells(lngRow - 1, columnToSum) + .Cells(lngRow, columnToSum)
                .Rows(lngRow).Delete
            End If

            lngRow = lngRow - 1
        Loop Until lngRow = 1
    End With
End Sub

Answer 4

Fusionar filas sumando los números de la columna D y construir una concatenación de cadenas desde la columna C con un delimitador de punto y coma basado en valores duplicados en las columnas A y B.

Before¹:

Código:

Sub merge_A_to_D_data()
    Dim rw As Long, lr As Long, str As String, dbl As Double

    Application.ScreenUpdating = False
    With ActiveSheet.Cells(1, 1).CurrentRegion
        .Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
                    Key2:=.Columns(2), Order2:=xlAscending, _
                    Orientation:=xlTopToBottom, Header:=xlYes
        lr = .Rows.Count
        For rw = .Rows.Count To 2 Step -1
            If .Cells(rw, 1).Value2 <> .Cells(rw - 1, 1).Value2 And _
               .Cells(rw, 2).Value2 <> .Cells(rw - 1, 2).Value2 And rw < lr Then
                .Cells(rw, 4) = Application.Sum(.Range(.Cells(rw, 4), .Cells(lr, 4)))
                .Cells(rw, 3) = Join(Application.Transpose(.Range(.Cells(rw, 3), .Cells(lr, 3))), Chr(59))
                .Cells(rw + 1, 1).Resize(lr - rw, 1).EntireRow.Delete
                lr = rw - 1
            End If
        Next rw
    End With
    Application.ScreenUpdating = True
End Sub

After¹:

¹ _{Se agregaron algunas filas adicionales de datos a los datos publicados originales para demostrar el orden.}

Answer 5

Esto hará lo que quieras.

Sub Macro()
Dim lngRow As Long
For lngRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
If StrComp(Range("B" & lngRow), Range("B" & lngRow - 1), vbTextCompare) = 0 Then
If Range("C" & lngRow) <> "" Then
Range("C" & lngRow - 1) = Range("C" & lngRow - 1) & ";" & Range("C" & lngRow)
Range("D" & lngRow - 1) = Range("D" & lngRow - 1) + Range("D" & lngRow)
End If
Rows(lngRow).Delete
End If
Next
End Sub

Answer 6

Aquí está mi solución

Sub MyCombine()
Dim i As Integer
ActiveSheet.Sort.SortFields.Add Key:=Range("A:A"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
    .SetRange Range("A:D")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlStroke
    .Apply
End With

i = 2

Do Until Len(Cells(i, 1).Value) = 0
    If Cells(i, 1).Value = Cells(i + 1, 1).Value Then
        Cells(i, 3).Value = Cells(i, 3).Value & ";" & Cells(i + 1, 3).Value
        Cells(i, 4).Value = Cells(i, 4).Value + Cells(i + 1, 4).Value
        Rows(i + 1).Delete
    Else
        i = i + 1
    End If
Loop    
End Sub