CODEWITHSUNDEEP
vbaexcel
Rufi0
Rufi0

Reputation: 37

Vba Excel - concatenate cell value and loop to all columns

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.

the result should be like this:

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!

Upvotes: 0

Views: 1700

Answers (3)

EEM
EEM

Reputation: 6659

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

Upvotes: 0

Scott Craner
Scott Craner

Reputation: 152450

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

Upvotes: 1

user3598756
user3598756

Reputation: 29421

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

Upvotes: 1

Related Questions