Combine every 10 cells into another cell then…

[Grand]

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.

 

[JoeMo]

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

Thanks for the tip, I will try it

I've added one line (in red) that should do that for you.

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()"
    .NumberFormat = "General"
    .Value = .Value
End With
Application.ScreenUpdating = True
End Sub

 

[Rick Rothstein]

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

I just realized that actually it is not important how many cells to take each time but what more important in my case is the length of the combined string which should not exceed 255 characters while at the same time maintaining the integrity of the original numbers.

The following macro will take the cells in Column A, combine them and then output them in chunks of text that are no larger than 255 characters (including the comma/space delimiters between them) while always ending the chunk on a whole cell entry. This code still relies on the fact than the text in the cells do not contain any spaces. Here is my code...

[table="width: 500"]
[tr]
	[td]Sub ChunksOf255OrLess()
  Dim X As Long, Space As Long, Text As String, TextMax As String, WrapText As String, Rws() As String
  Const MaxChars = 255
  Text = Replace(Application.Trim(Join(Application.Transpose(Range("A1", Cells(Rows.Count, "A").End(xlUp))), " ")), " ", ", ")
  Do While Len(Text) > MaxChars
    X = X + 1
    TextMax = Left(Text, MaxChars + 1)
    If Right(TextMax, 1) = " " Then
      WrapText = WrapText & RTrim(TextMax) & vbLf
      Text = Mid(Text, MaxChars + 2)
    Else
      Space = InStrRev(TextMax, " ")
      If Space = 0 Then
        WrapText = WrapText & Left(Text, MaxChars) & vbLf
        Text = Mid(Text, MaxChars + 1)
      Else
        WrapText = WrapText & Left(TextMax, Space - 1) & vbLf
        Text = Mid(Text, Space + 1)
      End If
    End If
  Loop
  Rws = Split(WrapText & Text, vbLf)
  Range("C1").Resize(UBound(Rws) + 1) = Evaluate("""Chunk: ""&ROW(1:" & UBound(Rws) + 1 & ")")
  Range("D1").Resize(UBound(Rws) + 1) = Application.Transpose(Rws)
End Sub[/td]
[/tr]
[/table]