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