Combine records

Sorry forgot to upload file example

TestData.xls

Hello cd_morris,

I'm confused.  On what basis should the entries associated with 12R096-3 be separated as per your example?

Regards,

Patrick

If there is only entry the one if then only once as is.  If multiple for a location then a in the exemple

1. Make a pivot table. (Refer the attachment)
2. Copy-Paste the pivot table.
3. Concatenate. (Refer the attachment)


Hope this helps.
Tils
Copy-of-TestData.xls

If only one entry fora data point (12R096-3) then there no nothing to do.

cd_morris,

Sorry, still not making sense.  In your example, Col B has only 2 distinct values, yet your sample output shows
three groups.  Why?

FWIW, I am liking tilsant's PT idea...

Patrick

i jus realised tht i've made some mistake.

this one is fine i guess..
Copy-of-TestData.xls

In my first attachment, i had put "Count of tmp1" in the "Data" field which i changed to "Sum of tmp2"........ which i hope is what cd_morris wants.

Good catch Patrick my mistake. They should
be in the same cell.

Tilsant, I undrstand the Pivoit table and the concatenation but items 1, item 2 and item 3 needs to be in the same cell

Example C11 would look like this:
Item 1 - 2
Item 2 - 2
Item 3 - 1

u intend to "merge" the cells??

Sub ReBorder(r2 As Range)
        With r2
            .Borders(xlEdgeLeft).LineStyle = xlNone
            .Borders(xlEdgeTop).LineStyle = xlNone
            .Borders(xlEdgeBottom).LineStyle = xlNone
            .Borders(xlEdgeRight).LineStyle = xlNone
            .Borders(xlInsideVertical).LineStyle = xlNone
            .Borders(xlInsideHorizontal).LineStyle = xlNone
            .BorderAround xlContinuous, xlMedium
        End With
        With r2.Offset(, 1)
            .Borders(xlEdgeLeft).LineStyle = xlNone
            .Borders(xlEdgeTop).LineStyle = xlNone
            .Borders(xlEdgeBottom).LineStyle = xlNone
            .Borders(xlEdgeRight).LineStyle = xlNone
            .Borders(xlInsideVertical).LineStyle = xlNone
            .Borders(xlInsideHorizontal).LineStyle = xlNone
            .BorderAround xlContinuous, xlMedium
        End With
End Sub

Sub combineme()
Application.ScreenUpdating = False
Dim r As Range, r2 As Range, r3 As Range, r4 As Range, oldVal As String
Set r3 = Sheets("Sheet1").Range("B11") '' << SET TARGET HERE (top left)
Set r4 = Sheets("Sheet1").Range("B2:B7") '' << SET SOURCE HERE
Set r = r4.Cells(1)
oldVal = ""
While r.Row < r4.Row + r4.Rows.Count
Set r2 = r
While r2.Offset(1).Value = r2.Value And r2.Offset(1, 1).Value = r2.Offset(, 1).Value
Set r2 = r2.Offset(1)
Wend
If r.Value = oldVal Then
    r3.Value = ""
Else
    r3.Value = r.Value
    If oldVal > "" Then ReBorder Range(r3.Offset(-1), r3.Offset(-1).End(xlUp))
    oldVal = r.Value
End If
r3.Offset(, 1).Value = r.Offset(, 1).Value & " - " & Application.WorksheetFunction.Sum(Range(r, r2).Offset(, 2))
Set r = r2.Offset(1)
Set r3 = r3.Offset(1)
Wend
If oldVal > "" Then ReBorder Range(r3.Offset(-1), r3.Offset(-1).End(xlUp))
Application.ScreenUpdating = True
End Sub

Select allOpen in new window

If u intend to merge the cells, then u can copy the table that we created (using the PT and then the concatenation stuff). U can paste this table on some other sheet (cell A1) and run the attached code.

Sub tmp()
For i = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
If Range("A" & i) = "" Then
    Range("B" & i - 1) = Range("B" & i - 1) & vbLf & Range("B" & i)
    Range("B" & i).EntireRow.Delete
End If
Next
End Sub

Select allOpen in new window

Copy-of-TestData.xls

Macro to merge from source to target

Sub combineme()
Application.ScreenUpdating = False
Sheets(1).Range("B11:C15").ClearContents
Dim r As Range, r2 As Range, r3 As Range, r4 As Range, s As String
Set r3 = Sheets("Sheet1").Range("B11") '' << SET TARGET HERE (top left)
Set r4 = Sheets("Sheet1").Range("B2:B7") '' << SET SOURCE HERE
Set r = r4.Cells(1)
While r.Row < r4.Row + r4.Rows.Count
s = ""
Set r2 = r
While r2.Offset(1).Value = r2.Value
While r2.Offset(1).Value = r2.Value And r2.Offset(1, 1).Value = r2.Offset(, 1).Value
Set r2 = r2.Offset(1)
Wend
s = s & r2.Offset(, 1).Value & " - " & Application.WorksheetFunction.Sum(Range(r, r2).Offset(, 2)) & Chr(10)
Set r2 = r2.Offset(1)
Set r = r2
Wend
s = s & r2.Offset(, 1).Value & " - " & Application.WorksheetFunction.Sum(Range(r, r2).Offset(, 2)) & Chr(10)
Set r = r2.Offset(1)
r3.Value = r.Offset(-1).Value
r3.Offset(, 1).Value = Left(s, Len(s) - 1)
Set r3 = r3.Offset(1)
Wend
Application.ScreenUpdating = True
End Sub

Select allOpen in new window