Vba Excel - concatenate cell value and loop to all columns - vba

Question

I need help.
In a sheet I need concatenate with a loop the columns "a" + "b" + "c", next the columns "d" + "e" + "f", etc ... an go up to the last column.
My script is locked to the second loop...
The concatenated results are to appear in a second sheet.
this is my incorrect code:
Sub concatena()
Dim x As String
Dim Y As String
b = 1 'colonna selezionata
For c = 1 To 5 'colonne concatenate da riportare
For q = 1 To 10 'righe su cui effettuare l'operazione
For t = 1 To 3 'numero celle da concatenare
For Each cell In Worksheets(1).Cells(q, t)
If cell.Value = "" Then GoTo Line1
x = x & cell(1, b).Value & "" & ""
Next
Next t
Line1:
On Error GoTo Terminate
Worksheets(2).Cells(q, c).Value = Mid(x, 1, Len(x))
x = "" 'mantiene la formattazione
Next q
b = 3 + 1 ' sposta il concatena di 3 celle la selezione delle colonne
Next c
Terminate: 'error handler
End Sub
Thank you all for the help!

Answer 1

This one uses arrays to speed it up a little:
Sub concatena()
Dim inArr() As Variant
Dim oArr() As Variant
Dim i&, j&
Dim ws As Worksheet
Dim rng As Range
Set ws = Worksheets("Sheet9") ' change to your worksheet
With ws
Set rng = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
inArr = rng.Value
ReDim oArr(1 To UBound(inArr, 1), 1 To UBound(inArr, 2) / 3)
For i = LBound(inArr, 1) To UBound(inArr, 1)
For j = LBound(inArr, 2) To UBound(inArr, 2) Step 3
oArr(i, Int((j - 1) / 3) + 1) = inArr(i, j) & inArr(i, j + 1) & inArr(i, j + 2)
Next j
Next i
rng.Clear
.Range("A1").Resize(UBound(oArr, 1), UBound(oArr, 2)).Value = oArr
End With

Answer 2

you can try this code:
Option Explicit
Sub concatena()
Dim iRow As Long, iCol As Long, iCol2 As Long
Dim arr As Variant
With Worksheets("numbers")
With .Cells(1, 1).CurrentRegion
ReDim arr(1 To .Rows.Count, 1 To .Columns.Count / 3 + .Columns.Count Mod 3)
For iRow = 1 To .Rows.Count
iCol2 = 1
For iCol = 1 To .Columns.Count Step 3
arr(iRow, iCol2) = Join(Application.Transpose(Application.Transpose(.Cells(iRow, iCol).Resize(, 3).Value)), "")
iCol2 = iCol2 + 1
Next iCol
Next iRow
Worksheets("results").Range("A1").Resize(.Rows.Count, UBound(arr, 2)).Value = arr
End With
End With
End Sub

Answer 3

This solution provides flexibility as it uses the variable bClls to hold the number of cells to be concatenated.
Assuming the source range is B2:M16 and you want to concatenate the value of every 3 cells for each row.
It avoids the use of redim.
Sub Range_Concatenate_Cells_TEST()
Dim rSel As Range
Dim bClls As Byte
Dim rCllOut As Range
bClls = 3 'change as required
Set rSel = ThisWorkbook.Sheets("Sht(0)").Range("B2:M16") 'change as required
Set rCllOut = ThisWorkbook.Sheets("Sht(1)").Cells(2, 2) 'change as required
Call Range_Concatenate_Cells(bClls, rSel, rCllOut)
End Sub
Sub Range_Concatenate_Cells(bClls As Byte, rSel As Range, rCllOut As Range)
Dim lRow As Long, iCol As Integer
Dim lRowOut As Long, iColOut As Integer
Dim vResult As Variant
With rSel
For lRow = 1 To .Rows.Count
lRowOut = 1 + lRowOut
iColOut = 0
For iCol = 1 To .Columns.Count Step 3
iColOut = 1 + iColOut
vResult = .Cells(lRow, iCol).Resize(1, 3).Value2
vResult = WorksheetFunction.Index(vResult, 0, 0)
vResult = Join(vResult, "")
rCllOut.Offset(-1 + lRowOut, -1 + iColOut).Value = vResult
Next: Next: End With
End Sub