I need help combining rows with VBA in Excel dynamically where the value is sometimes the same in one column.
Sample Data
A B C D E
1 r 10 5 3
1 r 12 8 2
2 q 60 50 40
2 q 25 45 55
2 q 100 200 300
EDIT: mistake in my sample data, changed last value in A from 3 to 2.
Ideally, I would combine the rows where the value is the same below in column B and while combining the values in C & D separated by semi colon and summing the values in column E.
It works when there is one duplicate, but not varying numbers of duplicates (dynamic combining)
Here is basically what I have tried:
Dim i As Long
i = 2
For i = 2 to lastRow
If Cells(i, 2).Value = Cells(i + 1, 2).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
We can work backwards. Before:
The sub:
Sub dural()
Dim i As Long
lastRow = 5
For i = lastRow To 2 Step -1
If Cells(i, 2).Value = Cells(i - 1, 2).Value Then
Cells(i - 1, 3).Value = Cells(i - 1, 3).Value & ";" & Cells(i, 3).Value
Cells(i - 1, 4).Value = Cells(i - 1, 4).Value + Cells(i, 4).Value
Rows(i).Delete
End If
Next i
End Sub
and after:
I think 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)
End If
Rows(lngRow).Delete
End If
Next
Columns("D:E").Select
Selection.ClearContents
End Sub
Related
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.
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
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())
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.
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
.Cells(lngRow, 11) = .Cells(lngRow, 8) & "; " & .Cells(lngRow + 1, 8)
should be
.Cells(lngRow, 11) = .Cells(lngRow, 8) & "; " & .Cells(lngRow + 1, 11)
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
I have written a bit of code that is intended to search cells in a column, see if they start with a certain string and then return a value based on that string in another column. I have two problems, firstly the loops don't actually return any values in columns 8,9,10 or 11. Also the second loop doesn't stop running? Here is my code
Sub Possible_solution_one()
Dim i As Integer
Dim j As Integer
Dim ws As Worksheet
Set ws = ActiveSheet
For i = 2 To ws.Cells(ws.Rows.Count, "a").End(xlUp).Row
Do While Cells(i, 1).Value <> ""
If Cells(i, 2) = "Business://EXTRACTS/" & "*" Then
Cells(i, 8) = "OBS(" & Cells(i, 2).Value & ",SHARE,#DI) OR "
End If
i = i + 1
Loop
Next
For j = 2 To ws.Cells(ws.Rows.Count, "a").End(xlUp).Row
Do While Cells(j, 6).Value <> ""
If Cells(j, 6) = "Business" & "*" Then
Cells(j, 9) = "OBS(" & Cells(j, 4).Value & ",SHARE,DI) OR "
ElseIf Cells(j, 6) = "CSTM" Then
Cells(j, 10) = "PUM(" & Cells(j, 4).Value & ",#D7) OR "
ElseIf Cells(j, 6) = "*FS" Then
Cells(j, 11) = "FCON(" & Cells(j, 4).Value & ") OR "
End If
i = i + 1
Loop
Next
End Sub
To give the situation I have 1 type of string in column B and 3 types in column F. Am looking to return different things in columns 8,9,10,11 based on b and D
If you are pattern matching with wildcards, you need to use the Like operator. e.g. If Cells(i, 2) Like "Business://EXTRACTS/" & "*" Then
The Do While loops inside the For Next loops were unnecessary. It is also not a good idea to 'manually' increment the increment counter in a For ... Next loop.
The second loop was running forever because you were incrementing i, not j.
A Select Case statement would make a better fit for the multiple criteria in the second j loop.
Sub Possible_solution_one()
Dim i As Long, j As Long
Dim ws As Worksheet
Set ws = ActiveSheet
With ws
For i = 2 To .Cells(.Rows.Count, "a").End(xlUp).Row
If Not CBool(Len(Cells(i, "a").Value)) Then Exit For
If .Cells(i, 2) = "Business://EXTRACTS/" & "*" Then
.Cells(i, 8) = "OBS(" & .Cells(i, 2).Value & ",SHARE,#DI) OR "
End If
Next i
For j = 2 To .Cells(ws.Rows.Count, "a").End(xlUp).Row
Select Case .Cells(j, 6).Value
Case "Business*"
.Cells(j, 9) = "OBS(" & Cells(j, 4).Value & ",SHARE,DI) OR "
Case "CSTM"
.Cells(j, 10) = "PUM(" & Cells(j, 4).Value & ",#D7) OR "
Case "*FS"
.Cells(j, 11) = "FCON(" & Cells(j, 4).Value & ") OR "
End If
End Select
Next j
End With
End Sub
I've also incorporated a With ... End With statement to associate all of the cells to the parent ws worksheet. Note hte .Cells and not Cells. The prefixing period assigns parentage to the worksheet referenced in the With ... End With.
With no sample data, I could not completely test this rewrite but it does compile.
your second do while loop uses i=i+1 instead of j = j + 1 so it's not going to increment the cells(j, 6).value if there's anything in cells(j,6) then the loop won't stop running
For j = 2 To ws.Cells(ws.Rows.Count, "a").End(xlUp).Row
Do While Cells(j, 6).Value <> ""
If Cells(j, 6) = "Business" & "*" Then
Cells(j, 9) = "OBS(" & Cells(j, 4).Value & ",SHARE,DI) OR "
ElseIf Cells(j, 6) = "CSTM" Then
Cells(j, 10) = "PUM(" & Cells(j, 4).Value & ",#D7) OR "
ElseIf Cells(j, 6) = "*FS" Then
Cells(j, 11) = "FCON(" & Cells(j, 4).Value & ") OR "
End If
'i = i + 1
j = j + 1
Loop
Next
I have a very large excel file, around 50K rows. In Column (C) I have the person numbers 1,1,1,1,2,3,4,5,.... and in Column(N) I have the payments for this person, so the data looks like
What I want is to sum All payments for one person from column N and set the result in column O, then merge column O.
It looks like you're looking for the built-in excel SUMIF function
=sumif(C:C,"specific person number",N:N)
Sub summAndMerge()
lastrow = Worksheets("A").Range("A65536").End(xlUp).Row
For i = 2 To lastrow
If Cells(i, 1).Value <> Cells(i - 1, 1).Value And Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
intUpper = i
Debug.Print ("<> -1 and <> +1 " & intUpper)
End If
If Cells(i, 1).Value <> Cells(i - 1, 1).Value And Cells(i, 1).Value = Cells(i + 1, 1).Value Then
intUpper = i
Debug.Print ("<> -1 and = +1 " & intUpper & " UPPPER LIMIT")
End If
If Cells(i, 1).Value <> Cells(i + 1, 1).Value And Cells(i, 1).Value = Cells(i - 1, 1).Value Then
Application.DisplayAlerts = False
Debug.Print ("<> +1 and = -1:" & i & "LOWER LIMIT")
Range(Cells(intUpper, 3), Cells(i, 3)).Merge
Cells(intUpper, 3).Value = "=sumif(B" & CStr(intUpper) & ":B" & CStr(i) & ","">0"")"
Range(Cells(i, 1), Cells(i, 24)).Borders(xlEdgeBottom).LineStyle = xlDouble
End If
If Cells(i, 1).Value <> Cells(i + 1, 1).Value And Cells(i, 1).Value <> Cells(i - 1, 1).Value Then
Debug.Print ("One Cells: " & i)
Range(Cells(i, 1), Cells(i, 24)).Borders(xlEdgeBottom).LineStyle = xlDouble
Cells(intUpper, 3).Value = Cells(intUpper, 2).Value
End If
Next i
End Sub
How can I repeat a fomula in a column? The fomula adds-up first 3 monthly values to get Quarterly in next column, then should move to next 3 values and so on.
Could you pelase help me? Thanks!
76
70
85
91
89
76
80
66
83
Sub sumer()
For i = 1 To 23 Step 3
Range("b" & i + 2).Value = Range("a" & i).Value + Range("a" & i + 1).Value +Range("a" & i + 2).Value
Next i
End Sub
let me know if this has answered your question
Sub SumQtr()
Dim lastRow As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 3 To lastRow Step 3
Cells(i, 3).Value = Cells(i - 2, 2).Value + Cells(i - 1, 2).Value + Cells(i, 2).Value
Next
End Sub
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.
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
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())
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.
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
.Cells(lngRow, 11) = .Cells(lngRow, 8) & "; " & .Cells(lngRow + 1, 8)
should be
.Cells(lngRow, 11) = .Cells(lngRow, 8) & "; " & .Cells(lngRow + 1, 11)
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