Excel loop condition based concatenation

Question

I am very new to excel macros and i need your help to fix one of my condition based concatenation problem.

i will explain the problem with simple scenario in below:

In my sheet , Column A contains customer name and Column B contains country names. Attached excel screenprint for reference ( column C and Column D will be my expected results)

In the column A, single customer name can be repeated as he can have multiple country representations

In the column B, countries placed as shown in the screenprint.

My expected results will be look alike in the column C and D as shown in the image.

I can do the column C using INDEX and i am able to get the unique values from column A

For the column D ,i am expecting the results in such a way that all countries will be concatenated and separated by ' / ' based on the corresponding customer in column A. I tried some vlookups and indexes, but i am unable to do it.

it would be really helpful if you could provide any suggestions(function/Macros) how it will be achieved.

Answer 1

I am a lower intermediate vba user, so I will admit that I am sure someone can do this better than , however, this works. Add a button and then click on it, or add this to the worksheet and it will occur whenever you choose for it to be fired:

Option Explicit
Sub listout()

  'declare your variables
  Dim wbk As Workbook
  Dim ws1 As Worksheet
  Dim cprange As Range
  Dim rmrange As Range
  Dim bottomRow As Long
  Dim row As Range
  Dim countname As Variant
  Dim copyname As Variant
  Dim nametoRow As Long

  'speed up process
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False

  'set what the variables are
  Set wbk = ThisWorkbook
  Set ws1 = wbk.Worksheets("Names List")
  bottomRow = ws1.Range("A1").End(xlDown).row

  'get ird of any excisting values
  ws1.Range("C1:D100").ClearContents

  'Set the range of the names that you want to copy, and put them into column C
  Set cprange = ws1.Range(Range("A1"), Range("A1" & bottomRow))
  ws1.Range(Range("C1"), Range("C1" & bottomRow)) = cprange.Value

  'then remove all the duplicates
  Set rmrange = ws1.Range(Range("C1"), Range("C1" & bottomRow))
  rmrange.RemoveDuplicates Columns:=1, Header:=xlNo

  'redclare the range as it will be shorter because you got rid of load sof duplicates
  Set rmrange = ws1.Range(Range("C1"), Range("C1").End(xlDown))

  'loop though each name in the 'unique' list and loop through their names in the original data then add the country to their new location in column D
  For Each copyname In rmrange
    For Each row In cprange
      nametoRow = ws1.Application.WorksheetFunction.Match(copyname, rmrange, False)
      countname = row.Offset(0, 1)
      If row.Value = copyname Then
        If Trim(ws1.Range("D" & nametoRow) & vbNullString) = vbNullString Then
          ws1.Range("D" & nametoRow) = countname
        Else
          ws1.Range("D" & nametoRow) = ws1.Range("D" & nametoRow) & "/ " & countname
        End If
      End If
    Next row
  Next copyname

  'turn these back on otherwise it messes with your computer/excel
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

Answer 2

Here is a more efficient method.

1. Advanced Filter to remove duplicates from Col A, paste on Col C
2. Set necessary ranges
3. Loop through each unique name
4. Build String
5. Paste String
6. Loop 4 - 6 until complete

Assumptions/Actions: You have headers on Col A, B, C, & D. If you have duplicate countries for a person, the country will show up twice on the string.You will need to change "Sheet1" to your sheet name on the 3rd line.

Usually you would need to check if your value is found using the .Find method, but the below logic does not allow for a cell to not be found as it is looping through values determined by filter. It wouldn't make since for a filtered object to not be found in the range it came from.

---

Option Explicit

Sub CountryList()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")

Dim FoundCell As Range, SearchRange As Range, Names As Range, SearchCell As Range
Dim MyString As String, i As Long

Set SearchRange = ws.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
    SearchRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("C2"), Unique:=True
    ws.Range("C2").Delete Shift:=xlShiftUp

Set Names = ws.Range("C2:C" & ws.Range("C" & ws.Rows.Count).End(xlUp).Row)

For Each SearchCell In Names
    Set FoundCell = SearchRange.Find(SearchCell)
        For i = 1 To Application.WorksheetFunction.CountIf(SearchRange, SearchCell)
            MyString = MyString & FoundCell.Offset(, 1) & "/"
            Set FoundCell = SearchRange.FindNext(FoundCell)
        Next i
    SearchCell.Offset(, 1) = Left(MyString, Len(MyString) - 1)
    MyString = ""
Next SearchCell

End Sub