How to concatenate adjacent cells in Excel VBA - 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