# Combine every 10 cells into another cell then…

#### Grand

##### Board Regular
Hi everybody, new here.
I need a macro that takes e.g. every 10 cells from let’s say column A (the length of column A varies from time to time so I don’t have a fix end) and combine the characters from those cells into one string which is comma separated and paste that into a single cell. Ideally the width of the receiving cell/column then should be a bit wider than standard like ~ 100. The width is not so important if that is complicated to do.
Here an example to illustrate:
 A C D 1224 Chunk 1: 1224, 2345, 2345, 3452 2345 Chunk 2: 5634, 1224, 2345, 2435 2345 Chunk 3: and so on 3452 Chunk 4: and so on 5634 so on 1224 2345 2435 3452 5634 1224 2345 2345 3452 5634 1224 2345 2345 3452 5634 end unknown

<tbody>
</tbody>

Any help is appreciated.
Thanks.

### Excel Facts

Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)

#### Sektor

##### Well-known Member
Re: How to combine every 10 cells into another cell then…

Code:
``````Sub DDD()

Dim r, j, s, rng

r = 1
Columns(3).NumberFormat = "@" 'Make sure number format is text
Do While True
Set rng = Cells(r, 1).Resize(10)
s = Join(Application.Index(Application.Transpose(rng.Value), 1, 0), ",")
j = j + 1
Cells(j, "B") = "Chunk " & j & ":"
Cells(j, "C") = s
If WorksheetFunction.CountA(rng) < 10 Or rng(rng.Count).Offset(1) = "" Then Exit Do
r = r + 10
Loop

End Sub``````

#### JoeMo

##### MrExcel MVP
Re: How to combine every 10 cells into another cell then…

Assumes your data start in A1.
Code:
``````Sub Chunky()
Dim R As Range, lR As Long, S() As String, i As Long, ct As Long
lR = Range("A" & Rows.Count).End(xlUp).Row
Set R = Range("A1:A" & lR)
ReDim S(1 To R.Count)
For i = 1 To R.Count Step 10
ct = ct + 1
If i + 9 <= lR Then
S(ct) = Join(Application.Transpose(Range("A" & i, "A" & i + 9)), ", ")
Else
S(ct) = Join(Application.Transpose(Range("A" & i, "A" & lR)), ", ")
End If
Next i
ReDim Preserve S(1 To ct)
Application.ScreenUpdating = False
Range("D1:D" & ct).Value = Application.Transpose(S)
With Range("C1:C" & ct)
.Formula = "= ""Chunk: "" & ROW()"
.Value = .Value
End With
Columns("C:D").AutoFit
Application.ScreenUpdating = True
End Sub``````

#### Grand

##### Board Regular
Re: How to combine every 10 cells into another cell then…

Code:
``````Sub DDD()

Dim r, j, s, rng

r = 1
Columns(3).NumberFormat = "@" 'Make sure number format is text
Do While True
Set rng = Cells(r, 1).Resize(10)
s = Join(Application.Index(Application.Transpose(rng.Value), 1, 0), ",")
j = j + 1
Cells(j, "B") = "Chunk " & j & ":"
Cells(j, "C") = s
If WorksheetFunction.CountA(rng) < 10 Or rng(rng.Count).Offset(1) = "" Then Exit Do
r = r + 10
Loop

End Sub``````

Thank you so much. It works fine except that it takes also empty cells; mostly in the last chunk where e.g. there are less than 10 cells with e.g 8 of them with value in them: result: "2345,3452,5634,1224,2345,2345,3452,5634,,". you can see that at the end of the string there are some commas afer ech other.
Can we tune it so it does the trick only when the cell is not equal empty, and so if it is empty, then it takes the next cell?
Thanks again.

#### Grand

##### Board Regular

Re: How to combine every 10 cells into another cell then…

Thank you JoeMo. You code forks also and just needs to take account for empty cells whcih is my mistake to not mention in my original post.
here is teh result from your code:
Code:
``````[TABLE="width: 472"]
<tbody>[TR]
[TD]= "Chunk: " & ROW()
[/TD]
[TD]fsdfse, tryry, rty, tryry, tyr, yrtrty, trydr, A, 1224, 2345
[/TD]
[/TR]
[TR]
[TD]= "Chunk: " & ROW()
[/TD]
[TD]2345, 3452, 5634, , 2345, 2435, 3452, 5634, 1224, 2345
[/TD]
[/TR]
[TR]
[TD]= "Chunk: " & ROW()
[/TD]
[TD]2345, , 5634, 1224, 2345, 2345, 3452, 5634
[/TD]
[/TR]
</tbody>[/TABLE]``````

as it can be seen there are some ", ," in the strings.

Also while we are at it, can we fine-tune it in such a way that the strings do not exceed 255 characters? in technical terms: if by adding the next cell's content we find out that the lenght of the string is going to be larger thatn 255 (including commas and spaces), we should stop there and take that last cell as the frist cell in the next chunk without breaking that number (whcih is in the last cell) into two pices?
Thank you very much.

#### Sektor

##### Well-known Member
Re: How to combine every 10 cells into another cell then…

Code:
``````Sub DDD()

Dim r, j, iIncr, s, iDiff, rng, rSize, iSize

r = 1
Columns(3).NumberFormat = "@" 'Make sure number format is text
rSize = Cells(1).End(xlDown).Row
Set rng = Range("A1")
Do While True
iDiff = rSize - iSize
iIncr = IIf(iDiff >= 10, 10, iDiff)
Set rng = rng.Resize(iIncr)
s = Join(Application.Index(Application.Transpose(rng.Value), 1, 0), ",")
j = j + 1
Cells(j, "B") = "Chunk " & j & ":"
Cells(j, "C") = s
iSize = iSize + iIncr
If iSize + 1 > rSize Then Exit Do
Set rng = rng.Offset(iIncr)
Loop

End Sub``````

#### Grand

##### Board Regular

Re: How to combine every 10 cells into another cell then…

Code:
``````Sub DDD()

Dim r, j, iIncr, s, iDiff, rng, rSize, iSize

r = 1
Columns(3).NumberFormat = "@" 'Make sure number format is text
rSize = Cells(1).End(xlDown).Row
Set rng = Range("A1")
Do While True
iDiff = rSize - iSize
iIncr = IIf(iDiff >= 10, 10, iDiff)
Set rng = rng.Resize(iIncr)
s = Join(Application.Index(Application.Transpose(rng.Value), 1, 0), ",")
j = j + 1
Cells(j, "B") = "Chunk " & j & ":"
Cells(j, "C") = s
iSize = iSize + iIncr
If iSize + 1 > rSize Then Exit Do
Set rng = rng.Offset(iIncr)
Loop

End Sub``````

Dear Sektor, Almost there; this one stops when it meet an empty cell. My intentions was that it should ignor empty cells (as if they are not there) and continue.
Could you also please check my 255 charachter lenght requirement whcih I stated in JoeMo's reply?
Thanks again

#### JoeMo

##### MrExcel MVP
Re: How to combine every 10 cells into another cell then…

Thank you JoeMo. You code forks also and just needs to take account for empty cells whcih is my mistake to not mention in my original post.
here is teh result from your code:
Code:
``````[TABLE="width: 472"]
<tbody>[TR]
[TD]= "Chunk: " & ROW()[/TD]
[TD]fsdfse, tryry, rty, tryry, tyr, yrtrty, trydr, A, 1224, 2345[/TD]
[/TR]
[TR]
[TD]= "Chunk: " & ROW()[/TD]
[TD]2345, 3452, 5634, , 2345, 2435, 3452, 5634, 1224, 2345[/TD]
[/TR]
[TR]
[TD]= "Chunk: " & ROW()[/TD]
[TD]2345, , 5634, 1224, 2345, 2345, 3452, 5634[/TD]
[/TR]
</tbody>[/TABLE]``````

as it can be seen there are some ", ," in the strings.

Also while we are at it, can we fine-tune it in such a way that the strings do not exceed 255 characters? in technical terms: if by adding the next cell's content we find out that the lenght of the string is going to be larger thatn 255 (including commas and spaces), we should stop there and take that last cell as the frist cell in the next chunk without breaking that number (whcih is in the last cell) into two pices?
Thank you very much.
This is lightly tested and could probably be cleaned up a bit. It will not work if any of your cells in col A contain more than 253 characters. Empty cells will not produce extra ", " delimiters, but will still be counted as contributing to the 10-cell chunk count.
Code:
``````Sub Chunky()
'Cells in col A must have no more than 253 characters
Dim R As Range, lR As Long, S() As String, StartRw As Long, EndRw As Long, ct As Long, L As Long
lR = Range("A" & Rows.Count).End(xlUp).Row
Set R = Range("A1:A" & lR)
ReDim S(1 To R.Count)
StartRw = 1
EndRw = 1
Again:
L = 0
Do Until EndRw > R.Count
L = L + Len(R.Cells(EndRw)) + 2
If L > 255 Then
EndRw = EndRw - 1
If EndRw - StartRw + 1 > 10 Then EndRw = StartRw + 9
Exit Do
ElseIf EndRw - StartRw + 1 > 10 Then
EndRw = StartRw + 9
Exit Do
Else
EndRw = EndRw + 1
End If
Loop
If StartRw <= EndRw And StartRw < R.Count Then
ct = ct + 1
If StartRw = EndRw Then
S(ct) = Range("A" & StartRw).Value
StartRw = EndRw + 1
EndRw = EndRw + 1
GoTo Again
Else
S(ct) = Replace(Application.Trim(Join(Application.Transpose(Range("A" & StartRw, "A" & EndRw)), " ")), " ", ", ")
StartRw = EndRw + 1
GoTo Again
End If
Else
ReDim Preserve S(1 To ct)
Application.ScreenUpdating = False
Columns("C:D").ClearContents
Range("D1:D" & ct).Value = Application.Transpose(S)
End If
With Range("C1:C" & ct)
.Formula = "= ""Chunk: "" & ROW()"
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub``````

#### Rick Rothstein

##### MrExcel MVP
Re: How to combine every 10 cells into another cell then…

Assuming you data cells have no spaces within them (as your posted example shows), here is another macro for you to try...
Code:
``````[table="width: 500"]
[tr]
[td]Sub ChunksOfTen()
Dim X As Long, Combined As String, Rws As Variant
Combined = Application.Trim(Join(Application.Transpose(Range("A1", Cells(Rows.Count, "A").End(xlUp)))))
Do
X = X + 10
Combined = Application.Substitute(Combined, " ", Chr(1) & "Chunk " & 1 + X / 10 & ":|", X)
Loop While X < Len(Combined)
Rws = Split(Replace("Chunk 1:|" & Combined, " ", ", "), Chr(1))
Range("B1").Resize(UBound(Rws) + 1) = Application.Transpose(Rws)
Columns("B").TextToColumns , xlDelimited, , , False, False, False, False, True, "|"
Columns("B:C").AutoFit
End Sub[/td]
[/tr]
[/table]``````

Last edited:

#### Grand

##### Board Regular
Re: How to combine every 10 cells into another cell then…

This is lightly tested and could probably be cleaned up a bit. It will not work if any of your cells in col A contain more than 253 characters. Empty cells will not produce extra ", " delimiters, but will still be counted as contributing to the 10-cell chunk count.
Code:
``````Sub Chunky()
'Cells in col A must have no more than 253 characters
Dim R As Range, lR As Long, S() As String, StartRw As Long, EndRw As Long, ct As Long, L As Long
lR = Range("A" & Rows.Count).End(xlUp).Row
Set R = Range("A1:A" & lR)
ReDim S(1 To R.Count)
StartRw = 1
EndRw = 1
Again:
L = 0
Do Until EndRw > R.Count
L = L + Len(R.Cells(EndRw)) + 2
If L > 255 Then
EndRw = EndRw - 1
If EndRw - StartRw + 1 > 10 Then EndRw = StartRw + 9
Exit Do
ElseIf EndRw - StartRw + 1 > 10 Then
EndRw = StartRw + 9
Exit Do
Else
EndRw = EndRw + 1
End If
Loop
If StartRw <= EndRw And StartRw < R.Count Then
ct = ct + 1
If StartRw = EndRw Then
S(ct) = Range("A" & StartRw).Value
StartRw = EndRw + 1
EndRw = EndRw + 1
GoTo Again
Else
S(ct) = Replace(Application.Trim(Join(Application.Transpose(Range("A" & StartRw, "A" & EndRw)), " ")), " ", ", ")
StartRw = EndRw + 1
GoTo Again
End If
Else
ReDim Preserve S(1 To ct)
Application.ScreenUpdating = False
Columns("C:D").ClearContents
Range("D1:D" & ct).Value = Application.Transpose(S)
End If
With Range("C1:C" & ct)
.Formula = "= ""Chunk: "" & ROW()"
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub``````

Thank you, except this here it works nicely:
Formula = "= ""Chunk: "" & ROW()"

but that is a minor thing.
Thanks gain.

Replies
2
Views
135
Replies
6
Views
304
Replies
1
Views
136
Replies
0
Views
365
Replies
2
Views
486

1,140,926
Messages
5,703,211
Members
421,282
Latest member
hogie

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

### Which adblocker are you using?

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back