VBA/Macro help needed with combine of rows based - Currently relying on 3rd party addon

[robospike]

Hi, I really hope someone can help...

I have an issue currently that I have overcome with a 3rd party add-on. I am sure there is a way to do this with a macro, however my attempts so far have failed. I am hoping someone can prove the power of VBA and Macros and enable the removal of the 3rd party add-on.

Basically the issue is, where there are several rows (that may not directly follow each other) that have the same data in column A but different data in other columns, there is a combine operation required.

Where two (or more) rows contain an identical value in column A, I want to merge the content of Column H and Column K separated with a new line.

Note: There is a header on row 1 and Column K may not always have a value.

eg:

	A	B	C	D	E	F	G	H	I	J	K
1	ID							Data1			Data2
2	111							test			example
3	111							fred
4	222							test2			apple
5	111							james			bob

<tbody>
</tbody>

The macro should result in the sheet looking like this:

	A	B	C	D	E	F	G	H	I	J	K
1	ID							Data1			Data2
2	111							test fred james			example bob
3	222							test2			apple
4
5

<tbody>
</tbody>

Any thoughts would be greatfully <!--[if gte mso 9]><xml> <o:OfficeDocumentSettings> <o:AllowPNG/> </o:OfficeDocumentSettings> </xml><![endif]-->received.

 

[Jeffrey Mahoney]

RoboSpike,

This is very possible. Are you wanting the macro to alter your current table or create a new table?

Jeff

 

[Jeffrey Mahoney]

Do you want the multiple items in columns H and K to separated by a comma, space, or other?

 

[robospike]

Hi Jeff,

That's great, I would ideally like it to work on the current sheet and to seperate values by placing them on a new line.

 

[Jeffrey Mahoney]

I think this code is very close to what you need. I'm assuming that the table starts in cell A1 with headers in row 1 and the data starts in row 2. If not, you can change the coordinates; look at the red text in the code. This assumes you have no other data around the table. No data below and no data to the right or left. This code will delete the duplicate rows after it combines the values in columns H and K. You should either make a copy of your table or test it on a sample. I tested it here and it worked.

Let me know if this works for you.

Jeff

Sub CombineRows()
  Dim Cel As Range
  Dim R As Range
  Dim IDs() As String
  Dim Data1 As String
  Dim Data2 As String
  Dim Found As Boolean
  Dim iCnt As Long
  Dim cID As String
  Dim X As Long
  Dim cc As Range
  Dim RR As Range
  Dim rCnt As Long
  Dim Y As Long
  Dim u As Range
  Dim ubool As Boolean
  
  
  Set R = Range(Range("[COLOR="#FF0000"]A2[/COLOR]"), Range("[COLOR="#FF0000"]A[/COLOR]" & Cells.Rows.Count).End(xlUp))   'Column of Id's
  rCnt = R.Rows.Count                                                   'Count of rows
  ReDim IDs(rCnt)
  
  For Each Cel In R                                                     'Look at all the ID's
    Y = Y + 1                                                           'Row number
    cID = Cel.Value                                                    'Current ID
    If iCnt > 0 Then                                                    'Have we stored this ID before
      Found = False
      For X = 1 To iCnt
        If IDs(X) = cID Then                                            'Does this ID match a stored ID
          Found = True                                                  'Yes
          Exit For
        End If
      Next X
    ElseIf iCnt = 0 Then
      Found = False
    End If
    
    If Found = True Then                                              'This matches a previously stored ID
      If ubool = True Then                                            'Join to delete row later
        Set u = Union(u, Cel)
      Else
        Set u = Cel
        ubool = True
      End If
      
    ElseIf Found = False Then                                                   'This is a new ID
      iCnt = iCnt + 1                                                           'Increment iCnt
      IDs(iCnt) = cID                                                           'Store ID
      
      If Len(Cel.Offset(0, 7).Value) > 0 Then Data1 = Cel.Offset(0, 7).Value    'Column H not empty
      If Len(Cel.Offset(0, 10).Value) > 0 Then Data2 = Cel.Offset(0, 10).Value  'Column K not empty
      If Y + 1 < rCnt Then                                                      'We are not at the next to last row
        Set RR = Range(Cel.Offset(1, 0), Range("[COLOR="#FF0000"]A[/COLOR]" & Cells.Rows.Count).End(xlUp))
      ElseIf Y + 1 = rCnt Then                                                  'We are at the next to last row
        Set RR = Cel.Offset(1, 0)
      End If
      If Y + 1 <= rCnt Then
        For Each cc In RR                                                       'Go find ID's that match the new ID
          If cc.Value = cID Then
            If Len(cc.Offset(0, 7).Value) > 0 Then Data1 = Data1 & Chr(10) & cc.Offset(0, 7).Value    'Column H not empty
            If Len(cc.Offset(0, 10).Value) > 0 Then Data2 = Data2 & Chr(10) & cc.Offset(0, 10).Value  'Column K not empty
          End If
        Next cc
        Cel.Offset(0, 7) = Data1
        Cel.Offset(0, 10) = Data2
      End If
    End If
  Next Cel
  
  If ubool = True Then
    u.EntireRow.Delete
  End If
          
  
  
End Sub

 

[robospike]

Hi Jeff,

That is amazing, I have just run it with an ~11200 rows and its completed all of the combines and left me with around 200 which look about right. I have to nip out now but will do some testing and get back to you, however its looking really good!!

 

[robospike]

Hi Jeff, I have run some tests with your code against some data sets, and the same with the 3rd party plugin. I am pleased to report that from what I have seen so far, the output is identical! This has made such a difference. Thanks so much!

 

[Jeffrey Mahoney]

I'm glad it helped. I hope with the comments that I added that you can decipher what to do if you need minor changes. Otherwise, just post to this thread and I'll get back to you soon. Cheers!