How to combine rows based on value in column A?

Hi all

I have spent some time searching and trying, but I haven't been able to solve my problem yet. Hope some can help me.

I have an Excel workbook containg several sheets that imports data from XML. One of the sheets contain data like this:
Column A - Column B - Column C
1000 - 1 - Data (text)
1000 - 2 - Data (text)
1000 - 3 - Data (text)
1001 - 1 - Data (text)
1002 - 1 - (empty)
1003 - 1 - Data (text)
1003 - 2 - Data (text)

The first row (A) is a uniqe identifier from a database, the second column (B) contains an index number to show how many records there is in the database for this uniqe identifier and finally column three (C) contains the actual data.

I need to combine the data so that I get all comments on the same row, prefferably in separate columns.

Once this is done I will use vlookup to take the cell content and put it on another worksheet before importing to another database.

All help and tips appriciated.

Best regards
Lars-Inge

Hi Arlette

I would like the output to be like this:
Column A - Column B - Column C - Column D
1000 - Data (text) - Data (text) - Data (text)
1001 - Data (text)
1002 - (empty)
1003 - Data (text) - Data (text)

The number of comments (data) varies from each uniqe ID, but at the moment I think there is 6 at the most.

Hope this helps.

Thanks, this works brilliant I think.

The only thing is that my question wasn't specific enough.

What happens, I think, is that it adds a column for all entries and since there is just about 18.000 rows it will be a lot of columns. Would it be possible to modify the macro (add a function) and get it to delete the rows where cell in column C is emtpy?

Not all issues has a comment, and these i don't need.

Hi

Yes, it could. Below is a quick and dirty "copy & paste" of the first few rows. No offence, but I honestly can't upload any file due to company policy. It does contain information that we don't want to lay out in the open... *S*


BAR-3467 1
BAR-3466 1
BAR-3466 2 Thanks for the info. Set to shared information.
CAS-3465 1
CAS-3465 2
CEL-3464 1
CEL-3463 1
CEL-3463 2 Hello.....
CAR-3462 1
CAR-3462 2
PAC-3461 1
ATL-3460 1
CAS-3459 1

As you can see, all issues will have at least one line, but they could be empty and therefore can be deleted. I don't know why they have done it like that, but it's down to the database and I can't do anything with it.

I really appriciate your time on this, at the moment it's a really big concern for me.

Sorry, didn't even think about that option...

Attached is a dummy workbook with the same setup as the original. I have only swappet out some comments with something else.

Is this what you wanted?

Hi jindon

It worked on the DummyWorkbook, but when I copy & paste the code to the "real" workbook it breaks (look at the code).

Sub test()
    Dim a, i As Long, txt As String, w, maxCol As Long, e, n As Long
    With Range("A2").CurrentRegion
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                If a(i, 3) <> "" Then
                    txt = a(i, 1)
                    If Not .exists(txt) Then
                        .Item(txt) = VBA.Array(a(i, 1))
                    End If
                    w = .Item(txt)
                    ReDim Preserve w(UBound(w) + 2)
                    w(UBound(w) - 1) = a(i, 2)
                    w(UBound(w)) = a(i, 3)
                    maxCol = Application.Max(maxCol, UBound(w))
                    .Item(txt) = w
                End If
            Next
            For Each e In .keys
                w = .Item(e)
                If UBound(w) < maxCol Then ReDim Preserve w(maxCol)
                .Item(e) = w
            Next
            w = .items: n = .Count
        End With
        With .Offset(, .Columns.Count + 3).Resize(n, maxCol + 1)
            .CurrentRegion.ClearContents
            .Value = _
            Application.Transpose(Application.Transpose(w))
            If maxCol + 1 > 3 Then
                With .Offset(, 1).Resize(1, 2)
                    .AutoFill .Resize(, maxCol)
                End With
            End If
            .Columns.AutoFit
        End With
    End With
End Sub

It breaks with:
Runtime error '13':
Type mismatch

I'll try to get this correct, but as you already have figured out, I'm not very good at this coding...

Best regards
Lars-Inge

If the output cell has more than 255 characters, Transpose function will fail.

Try this one

Sub test()
    Dim a, b(), i As Long, txt As String, w, maxCol As Long, n As Long
    With Range("a1").CurrentRegion
        a = .Value
        ReDim Preserve a(1 To UBound(a, 1), 1 To 100)
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 1 To UBound(a, 1)
                If a(i, 3) <> "" Then
                    txt = a(i, 1)
                    If Not .exists(txt) Then
                        n = n + 1
                        a(n, 1) = a(i, 1)
                        a(n, 2) = a(i, 2)
                        a(n, 3) = a(i, 3)
                        .Item(txt) = VBA.Array(n, 3)
                    Else
                        w = .Item(txt)
                        w(1) = w(1) + 2
                        If UBound(a, 2) < w(1) Then
                            ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + 100)
                        End If
                        a(w(0), w(1) - 1) = a(i, 2)
                        a(w(0), w(1)) = a(i, 3)
                        .Item(txt) = w
                        maxCol = Application.Max(maxCol, w(1))
                    End If
                End If
            Next
        End With
        With .Offset(, .Columns.Count + 3).Resize(n, maxCol)
            .CurrentRegion.ClearContents
            .Value = a
            If maxCol + 1 > 3 Then
                With .Offset(, 1).Resize(1, 2)
                    .AutoFill .Resize(, maxCol - 1)
                End With
            End If
            .Columns.AutoFit
        End With
    End With
End Sub

Originally Posted by ClassicVAG

Hi jindon

This works like a charm.

It does add a lot of columns that are empty, but it doesn't matter at all, I can use this one. Thank you very much for your assistance, you have saved me a lot of manual editing...

It shouldn't.

Col.C might be dirty as containing space/hidden characters etc.
try change

If a(i, 3) <> "" Then

to

If Application.Clean(Trim$(a(i, 3))) <> "" Then