Grouping muliple rows with same reference into single row

**kknb0800** · 08-15-2013, 10:07 AM

Hi,

I would like some help creating a macro to group multiple rows with the same reference into a single row.

In the first table is what I currently have and the second table is what I want to get to. I have also attached this example.

What I need is something to scan down column A and if it finds multiple instances of the same ref do:

1. insert a new row below and highlight it if possible and
2. copy the data from the above cells into the new row e.g. for Ref 011 below, there are 3 instances. The data in columns A, C and E is identical in each row so just copy that value once into the new row. The data in columns B and D are different so want all that data copied.

I would appreciate any help as this is beyond my capabilities.

Current table

Ref	Step 1	Step 2	Step 3	Step 4
007	Create Message with A indicator present	Feed message	Check for indicator A	Verify all details
008	Create Message with B indicator present	Feed message	Check for indicator B	Verify all details
008	Create Message with E indicator present	Feed message	Check for indicator E	Verify all details
010	Create Message with B indicator present	Feed message	Check for indicator B	Verify all details
011	Create Message with C indicator present	Feed message	Check for indicator C	Verify all details
011	Create Message with Z indicator present	Feed message	Check for indicator Z	Verify all details
011	Create Message with G indicator present	Feed message	Check for indicator G	Verify all details

Target table

Ref	Step 1	Step 2	Step 3	Step 4
007	Create Message with A indicator present	Feed message	Check for indicator A	Verify all details
008	Create Message with B indicator present	Feed message	Check for indicator B	Verify all details
008	Create Message with E indicator present	Feed message	Check for indicator E	Verify all details
008	Create Message with B indicator present Create Message with E indicator present	Feed message	Check for indicator B Check for indicator E	Verify all details
010	Create Message with B indicator present	Feed message	Check for indicator B	Verify all details
011	Create Message with C indicator present	Feed message	Check for indicator C	Verify all details
011	Create Message with Z indicator present	Feed message	Check for indicator Z	Verify all details
011	Create Message with G indicator present	Feed message	Check for indicator G	Verify all details
011	Create Message with C indicator present Create Message with Z indicator present Create Message with G indicator present	Feed message	Check for indicator C Check for indicator Z Check for indicator G	Verify all details

**kknb0800** · 08-15-2013, 10:12 AM

Forgot to mention that the data is already sorted on Ref (Column A)

**MickG** · 08-15-2013, 11:10 AM

Try this:-

Sub MG15Aug47
Dim Rng         As Range
Dim Dn          As Range
Dim L           As Byte
Dim k           As Variant
Dim nRng        As Range
Dim Ac          As Integer
Dim Txt         As String
Application.ScreenUpdating = False
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare

For L = 1 To 2

For Each Dn In Rng
    If Dn <> "" Then
        If Not .Exists(Dn.Value) Then
            .Add Dn.Value, Dn
        Else
            Set .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
        End If
    End If
Next

For Each k In .keys
  If L = 1 Then
        If .Item(k).Count > 1 Then
            If nRng Is Nothing Then
                Set nRng = .Item(k).Offset(.Item(k).Count).Resize(1)
            Else
                Set nRng = Union(nRng, .Item(k).Offset(.Item(k).Count).Resize(1))
            End If
        End If
    Else
        If .Item(k).Count > 1 Then
            For Ac = 1 To 4
                For Each Dn In .Item(k)
                    If Ac Mod 2 = 0 Then
                        Txt = Dn.Offset(, Ac)
                    Else
                        Txt = Txt & Dn.Offset(, Ac) & Chr(10)
                    End If
                Next Dn
                    With .Item(k).Offset(.Item(k).Count).Resize(1).Offset(, Ac)
                    .Value = Txt
                    .Rows.AutoFit
                    End With
                    Txt = vbNullString
            Next Ac
            
        End If
    End If
Next k
If L = 1 And Not nRng Is Nothing Then nRng.EntireRow.Insert
Next L
End With
Application.ScreenUpdating = True
End Sub

Regards Mick

**kknb0800** · 08-15-2013, 11:17 AM

Mick - Wow, this works perfectly! Thanks so much for the quick response

**MickG** · 08-15-2013, 11:25 AM

Your welcome
Regrds Mick

Grouping muliple rows with same reference into single row

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Grouping muliple rows with same reference into single row

Re: Grouping muliple rows with same reference into single row

Re: Grouping muliple rows with same reference into single row

Re: Grouping muliple rows with same reference into single row

Re: Grouping muliple rows with same reference into single row

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] Filter by entire grouping, not just single value

[SOLVED] Need to split multiple rows of four column grouping into a single row

Transpose muliple rows to single column

Combine muliple rows into one based on criteria

Converting a muliple page worksheet to a single page worksheet

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions