Link to home
Start Free TrialLog in
Avatar of Lia Nungaray
Lia NungarayFlag for United States of America

asked on

Help writing a small VBA module in Excel

Hello Experts,

I have a sheet with about 500 rows containing the following info:

Client      Affiliation
1001      Employee
1001      Spouse
1001      Child
1002      Employee
1002      Retiree
1002      Child
1002      Spouse
1003      Retiree
1003      Spouse
1004      Employee
1005      Retiree
1005      Dependent

I need to group the values in affiliation separated by a comma. So my end result would look like:

Client      Affiliation
1001      Employee, Spouse, ChildI
1002      Employe, Retiree, Child, Spouse
1003      Retiree, Spouse
1004      Employee
1005      Retiree, Dependent

I'm thinking that this can only be accomplished using VBA. 

Avatar of Peter Chan
Peter Chan
Flag of Hong Kong image

1. Ensure your data is always being sorted by Client column.
2. Have a loop to read  every row, and to create output into another sheet

Dim r0 as Integer,1. Ensure your data is always being sorted by Client column.
2. Have a loop to read  every row, and to create output into another sheet

Sub Copy_data()
   Dim r0 as Integer, r1 as Integer, Val_hold as String, Val_hold2 as String
   r1 = 1: r0 = 2: Val_hold = ""
   Worksheets("S1").Cells(1, 1).Value = "Client": Worksheets("S1").Cells(1, 2).Value = "Affiliation"
   Do While Worksheets("S0").Cells(r0, 1).Value <> ""
      If Val_hold <> Worksheets("S0").Cells(r0, 1).Value Then
         r1 = r1 +1
         Worksheets("S1").Cells(r1, 1).Value = Worksheets("S1").Cells(r0, 1).Value
         Worksheets("S1").Cells(r1, 2).Value = Worksheets("S1").Cells(r0, 2).Value
         Worksheets("S1").Cells(r1, 1).Value = Worksheets("S1").Cells(r1, 1).Value & ", " & Worksheets("S1").Cells(r0, 1).Value
      End If

      Val_hold = Worksheets("S0").Cells(r0, 1).Value
      r0=r0 + 1

End Sub

Open in new window

Avatar of Jan Karel Pieterse
If you happen to be on the Excel insider program and have access to the new functions called LAMBDA and SCAN, this is also a possibility:
User generated image
Avatar of Martin Liss
Martin Liss
Flag of United States of America image

Link to home
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
I’m glad I was able to help.

If you expand the “Full Biography" section of my profile you’ll find links to some articles I’ve written that may interest you.

Marty - Microsoft MVP 2009 to 2017
              Experts Exchange Most Valuable Expert (MVE) 2015, 2017
              Experts Exchange Distinguished Expert in Excel 2018
              Experts Exchange Top Expert Visual Basic Classic 2012 to 2020
              Experts Exchange Top Expert VBA 2018 to 2020
Avatar of Lia Nungaray


Thanks Martin, it worked exactly how I needed! Could you explain how this works? Why did you set TEMP_COL to 26? What do you find with "*"? And the use of "@"?
Sub GroupClients()
Dim lngLastRow As Long
Dim lngRow As Long
Dim ws As Worksheet
Dim colClients As New Collection
Dim lngEntry As Long
Const CLIENT_COL As Integer = 1
Const TEMP_COL As Integer = 26 ' 26 is column Z and I use Z and AA temporarily to store the merge results

Set ws = ActiveSheet

Application.ScreenUpdating = False

With ws
    lngLastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    ' Clear columns Z and AA 
    .Columns(TEMP_COL + 1).ClearContents

    .Columns(TEMP_COL).NumberFormat = "@" ' This line sets the cells in column Z to Text format
    .Columns(TEMP_COL + 1).NumberFormat = "@" ' This line sets the cells in column AA to Text format
   ' Loop through the data creating a keyed collection of unique Client values
    For lngRow = 2 To lngLastRow
        ' Collections that have keys throw an error if the addition of a duplicate key is attempted.
        ' The On Error suppresses the error message that would otherwise occur
        On Error Resume Next
        ' The format is collectionname.Add collection.value, collection.key
        colClients.Add .Cells(lngRow, CLIENT_COL), CStr(.Cells(lngRow, CLIENT_COL))
        On Error GoTo 0
    ' Loop through each row
    For lngRow = 2 To lngLastRow
        ' Loop through each member in the collection (collections start at 1)
        For lngEntry = 1 To colClients.Count
            If .Cells(lngRow, CLIENT_COL) = colClients(lngEntry) Then
                ' A Client is found that matches to collection key
                If Not IsEmpty(.Cells(lngEntry + 1, TEMP_COL)) Then
                    ' There's already data in column Z for the collection key so add the concatenate the value in column AA (which is CLIENT_COL + 1
                    ' with the data from the current Client row
                    .Cells(lngEntry + 1, TEMP_COL + 1) = .Cells(lngEntry + 1, TEMP_COL + 1) & ", " & .Cells(lngRow, CLIENT_COL + 1)
                    '  It's the first time we are dealing with a Client so just copy the data from columns A and B to Z and AA  
                    .Cells(lngEntry + 1, TEMP_COL) = .Cells(lngRow, CLIENT_COL)
                    .Cells(lngEntry + 1, TEMP_COL + 1) = .Cells(lngRow, CLIENT_COL + 1)
                End If
                Exit For
            End If
    .Range(.Cells(2, CLIENT_COL), .Cells(lngLastRow, CLIENT_COL + 1)).ClearContents
    For lngRow = 2 To colClients.Count + 1
        .Cells(lngRow, CLIENT_COL) = .Cells(lngRow, TEMP_COL)
        .Cells(lngRow, CLIENT_COL + 1) = .Cells(lngRow, TEMP_COL + 1)
    ' A better way of clear columns Z and AA 
    .Range(.Cells(2, TEMP_COL), .Cells(lngLastRow, TEMP_COL + 1)).ClearContents

End With

Application.ScreenUpdating = True

End Sub

Open in new window

Let me know if you still have questions.