Combine records

cd_morris
cd_morris used Ask the Experts™
on
I am looking for a way to combine like records an put the resoults in one cell.  Please see attached file!
Thanks in advanced!
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®

Author

Commented:
Sorry forgot to upload file example

TestData.xls
Top Expert 2010

Commented:
Hello cd_morris,

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

Regards,

Patrick

Author

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

Commented:
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

Author

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

Commented:
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

Commented:
i jus realised tht i've made some mistake.

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

Commented:
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.

Author

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

Author

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

Author

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

Commented:
u intend to "merge" the cells??
Expert of the Quarter 2010
Expert of the Year 2010

Commented:

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

Open in new window

Commented:
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

Open in new window

Copy-of-TestData.xls
Expert of the Quarter 2010
Expert of the Year 2010

Commented:
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

Open in new window

Top Expert 2010
Commented:
cd_morris,

For the record, I still think you are best served with a PivotTable, but if you must do this, this seems to work
pretty well.

It assumes that you have headings in Row 1, and data in A2:C???.  The results are returned to a new
worksheet.  The code uses a "Dictionary of Dictionaries" to keep track of everything.

Patrick
Sub DoIt()
    
    Dim dic As Object
    Dim dic2 As Object
    Dim arr As Variant
    Dim r As Long, r2 As Long
    Dim LastR As Long
    Dim WriteStr As String
    Dim Keys As Variant, Items As Variant
    
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = vbTextCompare
    
    With ActiveSheet
        LastR = .Cells(.Rows.Count, 1).End(xlUp).Row
        arr = .Range("a2:c" & LastR).Value
    End With
        
    For r = 1 To UBound(arr, 1)
        If dic.Exists(arr(r, 1)) Then
            Set dic2 = dic.Item(arr(r, 1))
            If dic2.Exists(arr(r, 2)) Then
                dic2.Item(arr(r, 2)) = dic2.Item(arr(r, 2)) + arr(r, 3)
            Else
                dic2.Add arr(r, 2), arr(r, 3)
            End If
        Else
            Set dic2 = CreateObject("Scripting.Dictionary")
            dic2.CompareMode = vbTextCompare
            dic2.Add arr(r, 2), arr(r, 3)
            dic.Add arr(r, 1), dic2
        End If
    Next
    
    Worksheets.Add
    
    [a1:b1].Value = Array("Code", "Item - Qty")
    
    arr = dic.Keys
    [a2].Resize(UBound(arr) + 1, 1).Value = Application.Transpose(arr)
    For r = 0 To UBound(arr)
        Set dic2 = dic.Item(arr(r))
        Keys = dic2.Keys
        Items = dic2.Items
        WriteStr = ""
        For r2 = 0 To dic2.Count - 1
            WriteStr = WriteStr & Chr(10) & Keys(r2) & " - " & Items(r2)
        Next
        WriteStr = Mid(WriteStr, 2)
        Cells(r + 2, 2) = WriteStr
    Next
    
    With [b:b]
        .ColumnWidth = 40
        .WrapText = True
    End With
    Columns.AutoFit
    Rows.AutoFit
    
    Set dic2 = Nothing
    Set dic = Nothing
    
    MsgBox "Done"
    
End Sub

Open in new window

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial