Thread: Concatenate Multiple Cells

Another possible route would be something like:

Public Sub Example()
Dim lngSno As Long, lngMax As Long, lngRowS As Long, lngRowE As Long, vData As Variant
lngMax = 1 + Application.Max(Columns(1))
With Columns(4)
    .Insert
    .Offset(, -1).Cells(2).Value = "Address"
    .Offset(, -2).Cells(2).Value = "Name"
End With
Cells(Rows.Count, "C").End(xlUp).Offset(1, -2).Value = lngMax
For lngSno = 1 To lngMax - 1 Step 1
    lngRowS = Application.Match(lngSno, Columns(1), 0)
    lngRowE = Cells(lngRowS, "A").End(xlDown).Row
    vData = Application.Transpose(Range(Cells(lngRowS + 1, "C"), Cells(lngRowE - 1, "C")))
    With Cells(lngRowS, "D")
        .Value = Join(vData, Chr(10))
        .WrapText = True
    End With
Next lngSno
On Error Resume Next
Range(Cells(4, "A"), Cells(Rows.Count, "A").End(xlUp)).Offset(, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

(certain assumptions are made in line with content of sample - ie blanks rather than nulls)

Hello rohit475,

Here is another version of the macro. A button has been added to the "Current" worksheet to run the macro in the attached workbook. Here is the code.

Sub ConcatenateRows()

  Dim Addx As String
  Dim N As Long
  Dim R As Long
  Dim Rng As Range
  Dim Wks As Worksheet
    
    Set Wks = Worksheets("Current")
    
      Wks.Columns("D").EntireColumn.Insert Shift:=xlToRight
      Set Rng = Wks.UsedRange
      Rng.Cells(1, "C") = "Name"
      Rng.Cells(1, "D") = "Address"
      
        N = 3
      
        For R = 3 To Rng.Rows.Count
          If Rng.Cells(R, "B") = "" Then
             Addx = Addx & Rng.Cells(R, "C") & vbLf
          Else
             If Len(Addx) > 1 Then Rng.Cells(N, "D") = Left(Addx, Len(Addx) - 1)
             N = R
             Addx = ""
          End If
        Next R
      
      If Len(Addx) > 1 Then Rng.Cells(N, "D") = Left(Addx, Len(Addx) - 1)
      
      On Error Resume Next
      Set Rng = Rng.Offset(2, 0).Resize(Rng.Rows.Count - 2, 1)
      Rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    
End Sub