How to concatenate adjacent cells in Excel VBA

Question

I have data in a single column. Some of the cells starts with "index" like: (1), (2), etc. I want to concatenate such cells in order, and place the result to the next column, and clear the original cells. Could you please tell me how to do this in VBA? Thank you!

Please see the picture: col_A has the data, col_C and col_D are the desired result

Answer 1

You could do something like this. I can't vouch for it as I've only tested in on your sample case. So it won't work for non-contiguous numbered sub-entries - nor will it work for cases where the sub-entries are not in order. Both of the later could, of course, be incorporated into a more robust version that you've have to refactor on your own. In fact the regular expression already picks up the sub-entry # if you want to implement the latter.

Sub process()
 Dim maxRow As Integer: maxRow = 100
 Dim items As Collection
 Dim regEx As Object
 Dim matches As Object
 Set items = New Collection

 Set re = CreateObject("vbscript.regexp")
 re.Global = True
 re.IgnoreCase = True
 re.Pattern = "\((\d+)\).*"

 Dim val As String
 Dim row As Integer, rowPtr As Integer: row = 1
 Dim matchTest As Boolean, preMatchTest As Boolean: preMatchTest = False
 Do While row < maxRow:
   val = Cells(row, "A").Value
   matchTest = re.Test(val)
   If Not preMatchTest And matchTest Then
     rowPtr = row
     Do While row < maxRow + 1:
        val = Cells(row, "A").Value
        matchTest = re.Test(val)
        If matchTest Then
          Set matches = re.Execute(val)
          itemNum = matches(0).submatches(0)
          items.Add val
          Cells(row, "A") = ""
        Else
          For Each colVal In items:
            Cells(rowPtr - 1, "B") = Cells(rowPtr - 1, "B") & colVal
          Next
          Set items = New Collection
          Exit Do
        End If
        row = row + 1
        preMatchTest = matchTest
     Loop
   End If
   preMatchTest = False
   row = row + 1
 Loop

End Sub

The prematch/match if statement looks for the start of sub-entries and once found goes into the inner loop that adds them to the 'items' collection. After the last one is found the collection is concatenated and stored at the saved location ('rowPtr') of the main entry. Also note that column 'A' and the max # of rows looked at (maxRow) are hardcoded into the macro.

Answer 2

you could use AutoFilter() method and Areas property of Range object

Option Explicit

Sub main()
    Dim area As Range

    With Range("A1", Cells(Rows.Count, 1).End(xlUp)).Offset(, 2)
        .Offset(, -2).Copy .Cells
        .AutoFilter Field:=1, Criteria1:="(*"
        If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then
            For Each area In .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Areas
                area(1).Offset(-1, 1).Value = Join(Application.Transpose(area.Value), "")
                area.ClearContents
            Next
        End If
        .Parent.AutoFilterMode = False
    End With
End Sub