CODEWITHSUNDEEP
excelvbaconcatenation
PGNewbie
PGNewbie

Reputation: 15

Concatenate Multiple values in one cell excell vba

I am using two workbooks to search for missing information that is in one book but not in the other. My code works but in some instances I have multiple values being returned and only one value is entered in to the cell, I need to concatenate the other values in to the same cell with a "," in between each value

  Dim w1 As Worksheet, w2 As Worksheet
  Dim wbnew As Workbook
  Dim c As Range, FR As Variant
  Dim d As Range
  Dim e As Range

  Application.ScreenUpdating = False


  Set w2 = Workbooks("Book2.xlsx").ActiveSheet
  Set w1 = Workbooks("Book1.xlsx").ActiveSheet



For Each c In w1.Range("C2", w1.Range("C" & Rows.Count).End(xlUp))
FR = Application.Match(c, w2.Columns("C"), 0)
If IsNumeric(FR) Then
c.Offset(, 1).Value = w2.Range("D" & FR).Value
End If

Next c

Upvotes: 0

Views: 131

Answers (2)

Tim Williams
Tim Williams

Reputation: 166885

EDIT: tested this one...

Sub Tester()

    Dim w1 As Worksheet, w2 As Worksheet, c As Range
    Dim arr, r As Long, result As String, sep As String

    Set w1 = Sheet1
    Set w2 = Sheet2

    arr = w2.Range("C2:C" & w2.Cells(Rows.Count, "C").End(xlUp).Row).Resize(, 2).Value

    For Each c In w1.Range(w1.Range("C2"), w1.Cells(Rows.Count, "C").End(xlUp))
        If Len(c) > 0 Then
            result = ""
            sep = ""
            For r = 1 To UBound(arr, 1)
                If arr(r, 1) = c Then
                    result = result & sep & arr(r, 2)
                    sep = ","
                End If
            Next r
            c.Offset(0, 1).Value = result
        End If
    Next c

End Sub

Upvotes: 1

PGNewbie
PGNewbie

Reputation: 15

I was able to resolve the issue with the follow code. Thank you everyone for your help! :)

Dim w1 As Worksheet, w2 As Worksheet Dim Cl As Range Application.ScreenUpdating = False

Set w2 = Workbooks("Book2.xlsx").ActiveSheet

Set w1 = Workbooks("Book1.xlsx").ActiveSheet

With CreateObject("scripting.dictionary")

  For Each Cl In w2.Range("C2", w2.Range("C" & Rows.Count).End(xlUp))
     If Not .Exists(Cl.Value) Then
        .Add Cl.Value, Cl.Offset(, 1).Value
     Else
        .Item(Cl.Value) = .Item(Cl.Value) & "," & Cl.Offset(, 1).Value
     End If
  Next Cl
  For Each Cl In w1.Range("C2", w1.Range("C" & Rows.Count).End(xlUp))
     If .Exists(Cl.Value) Then Cl.Offset(, 1).Value = .Item(Cl.Value)
  Next Cl
 End With`

Upvotes: 0

Related Questions