Combine every 10 cells into another cell then…

Grand

Board Regular
Joined
May 11, 2017
Messages
52
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
CD
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

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
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
 
Upvote 0
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
 
Upvote 0
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.
 
Upvote 0
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.
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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:
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,213,585
Messages
6,114,520
Members
448,575
Latest member
hycrow

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.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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
Back
Top