Excel VBA - How to Unify Rows [duplicate] - vba

Question

I am trying to find duplicate values in one column and combine the values of a second column into one row. I also want to sum the values in a third column.
For example:
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
Would become
A B C D
k 9 t;o;p;j 22
h 4 w;u;g;f 19
The code I have been using for the first part of this is
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
(please forgive the indentation)
The problem that I am running into is that it will find the first pair of duplicates, but not all. So I get a result that looks like this:
A B C D
k 9 t;o 12
k 9 p;j 10
h 4 w;u 8
h 4 g;f 11
Thoughts?
Thank you in advance.

Answer 1

Try changing your code to this:
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
Tested
EDIT
To make it a little easier to adjust to different column I added variables at the beginning to indicate which column do what. Note that column 2 (B) isn't used in the current logic.
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 2

This looks sloppy and complicated. Both are true, but it works pretty fine.
Note! I always recommend to define all DIMs like: ranges, integers, etc. Storing the last row to a variable like LngRow is best (not like the whole App.WksFunc.COUNTA). I also like to use functions directly on cells where possible (like the SUMIFS ex. below). Thus, based on your example configuration (columns 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

Merging rows by summing the numbers from column D and building a string concatenation from column C with a semi-colon delimiter based upon duplicate values in columns A and B.
Before¹:
        
Code:
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¹:
        
¹Some additional rows of data were added to the original posted data in order to demonstrate the sort.

Answer 4

Here is my solution
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

Answer 5

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

Answer 6

This will do what you want.
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