Sub test()
LastRow_Sheet1 = Worksheets("Sheet1").UsedRange.Rows.Count
LastRow_Sheet2 = Worksheets("Sheet2").UsedRange.Rows.Count
For x = 2 To 30
po_number = Worksheets("Sheet1").Cells(x, 1).Value
site_name = Worksheets("Sheet1").Cells(x, 2).Value
For y = 2 To LastRow_Sheet2
If po_number <> Worksheets("Sheet1").Cells(y, 1).Value Then ' And (InStr(1, Cells(y, 30), CStr(site_name)) >= 1) Then
With Worksheets("Sheet2")
If InStr(1, .Cells(y, 30), CStr(site_name)) >= 1 Then
.Range(.Cells(y, 1), .Cells(y, 31)).Copy
nextRow = Sheets("Sheet3").Cells(Sheets("Sheet3").Rows.Count, 1).End(xlUp).Row + 1
Sheets("Sheet3").Range("A" & nextRow).PasteSpecial
End If
End With
End If
Next
Next
End Sub
Hi All,
Question 1, will these two if syntax have same result ?
If po_number <> Worksheets("Sheet1").Cells(y, 1).Value And (InStr(1, Cells(y, 30), CStr(site_name)) >= 1) Then
With Worksheets("Sheet2")
.Range(.Cells(y, 1), .Cells(y, 31)).Copy
nextRow = Sheets("Sheet3").Cells(Sheets("Sheet3").Rows.Count, 1).End(xlUp).Row + 1
Sheets("Sheet3").Range("A" & nextRow).PasteSpecial
End With
End If
If po_number <> Worksheets("Sheet1").Cells(y, 1).Value Then
With Worksheets("Sheet2")
If InStr(1, .Cells(y, 30), CStr(site_name)) >= 1 Then
.Range(.Cells(y, 1), .Cells(y, 31)).Copy
nextRow = Sheets("Sheet3").Cells(Sheets("Sheet3").Rows.Count, 1).End(xlUp).Row + 1
Sheets("Sheet3").Range("A" & nextRow).PasteSpecial
End If
End With
End If
Question 2, It seems that my original code will output the result twice .. could anyone help me to define that?
Many thanks ..
Related
I am getting
Run-time error 13: Type mismatch
on my code below:
Dim C As Integer, CoSheet As Worksheet
For Each CoSheet In Workbooks(ListBoxWbk.Value).Worksheets
For C = 1 To 10
'Error on code below
Sheet2.Range("A1048573").End(xlUp).Offset(1, 0).Value = Workbooks(ListBoxWbk.Value).Sheets(CoSheet).Cells(1, 15) & "-1"
Sheet2.Range("B1048573").End(xlUp).Offset(1, 0).Value = Workbooks(ListBoxWbk.Value).Sheets(CoSheet).Cells(C, 2)
Sheet2.Range("C1048573").End(xlUp).Offset(1, 0).Value = Workbooks(ListBoxWbk.Value).Sheets(CoSheet).Cells(C, 4)
Sheet2.Range("D1048573").End(xlUp).Offset(1, 0).Value = Workbooks(ListBoxWbk.Value).Sheets(CoSheet).Cells(C, 5)
Sheet2.Range("E1048573").End(xlUp).Offset(1, 0).Value = Workbooks(ListBoxWbk.Value).Sheets(CoSheet).Cells(C, 6)
Sheet2.Range("F1048573").End(xlUp).Offset(1, 0).Value = Workbooks(ListBoxWbk.Value).Sheets(CoSheet).Cells(C, 7)
Next C
Next CoSheet
All your lines with:
Workbooks(ListBoxWbk.Value).Sheets(CoSheet)...
Should be replaced with:
CoSheet...
Modified Code
For Each CoSheet In Workbooks(ListBoxWbk.Value).Worksheets
For C = 1 To 10
Sheet2.Range("A1048573").End(xlUp).Offset(1, 0).Value = CoSheet.Cells(1, 15) & "-1"
Sheet2.Range("B1048573").End(xlUp).Offset(1, 0).Value = CoSheet.Cells(C, 2)
Sheet2.Range("C1048573").End(xlUp).Offset(1, 0).Value = CoSheet.Cells(C, 4)
Sheet2.Range("D1048573").End(xlUp).Offset(1, 0).Value = CoSheet.Cells(C, 5)
Sheet2.Range("E1048573").End(xlUp).Offset(1, 0).Value = CoSheet.Cells(C, 6)
Sheet2.Range("F1048573").End(xlUp).Offset(1, 0).Value = CoSheet.Cells(C, 7)
Next C
Next CoSheet
Note: if you are trying to paste at the first empty row, you could use something like the code below:
Dim C As Integer, CoSheet As Worksheet
Dim LastRow As Long
For Each CoSheet In Workbooks(ListBoxWbk.Value).Worksheets
For C = 1 To 10
LastRow = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row ' <-- getting last row in column "A"
Sheet2.Range("A" & LastRow + 1).Value = CoSheet.Cells(1, 15) & "-1"
Sheet2.Range("B" & LastRow + 1).Value = CoSheet.Cells(C, 2)
Sheet2.Range("C" & LastRow + 1).Value = CoSheet.Cells(C, 4)
Sheet2.Range("D" & LastRow + 1).Value = CoSheet.Cells(C, 5)
Sheet2.Range("E" & LastRow + 1).Value = CoSheet.Cells(C, 6)
Sheet2.Range("F" & LastRow + 1).Value = CoSheet.Cells(C, 7)
Next C
Next CoSheet
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
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 wrote the following code to merge cells in excel, the data is around 26000 rows, the code is running on core I7 CPU with 8 GB RAM, the problem that it still working since 4 days, the average rows per day is 3000 row!, any one know how to get the result, because its a report that should be delivered since three days!
Sub MergeCellss()
lastRow = Worksheets("A").Range("A65536").End(xlUp).Row
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
For i = 2 To lastRow
If Cells(i, 2).Value <> Cells(i - 1, 2).Value And Cells(i, 2).Value <> Cells(i + 1, 2).Value Then
intUpper = i
Debug.Print ("<> -1 and <> +1 " & intUpper)
End If
If Cells(i, 2).Value <> Cells(i - 1, 2).Value And Cells(i, 2).Value = Cells(i + 1, 2).Value Then
intUpper = i
Debug.Print ("<> -1 and = +1 " & intUpper & " UPPPER LIMIT")
End If
If Cells(i, 2).Value <> Cells(i + 1, 2).Value And Cells(i, 2).Value = Cells(i - 1, 2).Value Then
Application.DisplayAlerts = False
Debug.Print ("<> +1 and = -1:" & i & "LOWER LIMIT")
DoEvents
For x = 1 To 8
Range(Cells(intUpper, x), Cells(i, x)).Merge
Next x
For j = 18 To 26
Range(Cells(intUpper, j), Cells(i, j)).Merge
Next j
Cells(intUpper, 14).Value = "=sumif(M" & CStr(intUpper) & ":M" & CStr(i) & ","">0"")"
Range(Cells(intUpper, 14), Cells(i, 14)).Merge
Range(Cells(i, 1), Cells(i, 26)).Borders(xlEdgeBottom).LineStyle = xlDouble
End If
If Cells(i, 2).Value <> Cells(i + 1, 2).Value And Cells(i, 2).Value <> Cells(i - 1, 2).Value Then
Debug.Print ("One Cells: " & i)
Range(Cells(i, 1), Cells(i, 26)).Borders(xlEdgeBottom).LineStyle = xlDouble
Cells(intUpper, 14).Value = Cells(intUpper, 13).Value
DoEvents
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
the code above will merge the all cells containing repeated data like User Name, Date of Birth, .... into one cell, and leave the training courses and experiences as it is.
I wonder how can I run this code in less than 1 hour.
Here is some rewrite on your code. The two primary differences are the use of If ... ElseIf ... End If and the grouping of the first and fourth conditional operations (the conditions were the same).
Sub Merge_Cells()
Dim lastRow As Long, rw As Long
Dim intUpper As Long, x As Long
Dim vVALs As Variant
appTGGL bTGGL:=False
Debug.Print Timer
With Worksheets("A")
.Cells(1, 1) = Timer
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For rw = 2 To lastRow
vVALs = Array(.Cells(rw - 1, 2).Value, .Cells(rw, 2).Value, .Cells(rw + 1, 2).Value)
If vVALs(1) <> vVALs(0) And vVALs(1) <> vVALs(2) Then
'the first and fourth conditions were the same so they are both here
'original first If condition
intUpper = rw
'Debug.Print ("<> -1 and <> +1 " & intUpper)
'original fourth If condition
'Debug.Print ("One Cells: " & rw)
.Range(.Cells(rw, 1), .Cells(rw, 26)).Borders(xlEdgeBottom).LineStyle = xlDouble
.Cells(intUpper, 14).Value = .Cells(intUpper, 13).Value
ElseIf vVALs(1) <> vVALs(0) And vVALs(1) = vVALs(2) Then
intUpper = rw
'Debug.Print ("<> -1 and = +1 " & intUpper & " UPPPER LIMIT")
ElseIf vVALs(1) = vVALs(0) And vVALs(1) <> vVALs(2) Then
'Debug.Print ("<> +1 and = -1:" & rw & "LOWER LIMIT")
For x = 1 To 26
If x < 9 Or x > 17 Then _
.Range(.Cells(intUpper, x), .Cells(rw, x)).Merge
Next x
.Cells(intUpper, 14).Value = "=sumif(M" & CStr(intUpper) & ":M" & CStr(rw) & ","">0"")"
.Range(.Cells(intUpper, 14), .Cells(rw, 14)).Merge
.Cells(rw, 1).Resize(1, 26).Borders(xlEdgeBottom).LineStyle = xlDouble
End If
Next rw
.Cells(1, 2) = Timer
End With
Debug.Print Timer
appTGGL
End Sub
Sub appTGGL(Optional bTGGL As Boolean = True)
Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
Application.ScreenUpdating = bTGGL
Application.EnableEvents = bTGGL
Application.DisplayAlerts = bTGGL
End Sub
I've also read the three primary conditional values into a variant array to reduce repeated worksheet value reads.
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