Split cells into specific number of characters

[eagiordano]

Hello all.

We are trying to split the numbers column (D) into the count of characters number in column B. With the results on sheet 2 with the SKU and brand next to them. The main issue we have is that we want it split on the semi colon on either the character count number or less. So it does not break the numbers. Also to then replace the semi colon with a space in the output.

Please see below and example of the output we require.

If anyone could suggest a way to do this using a macro that would be greatly appreciated.

Many thanks.

 

[rlv01]

FWIW, when you post an image of your data instead of something that can be copied and pasted into a spreadsheet, it is difficult for others to experiment with it. Which means your chances of getting help drop significantly. Instead, use the free XL2BB tool (link below) to post your data in a way that makes it accessible to others.

XL2BB - Excel Range to BBCode

Excel 'mini-sheet' in messages - XL2BB Although experts prefer to read your description and question instead of working in your actual file to solve your problem, there are times that it is difficult to explain an issue without providing actual...

www.mrexcel.com

 

[eagiordano]

Thanks @rlv01. Please see the data below

SKU	Character Count	Brand	Numbers
65442​	30​	Rehau	384;385;484;485XL;495;584;585;684;685;784;785;884;885
65454​	44​	Nike	2610;2910;3610;3910;4110;4610;5110;5610;5635;5640;5640;6410;6610;6635;6640;6640;6710;6810;7410;7610;7635;7710;7740;7740;7810;7840;7840;7910;8000;8210;8240;8240;8260;8340;8340;8360;8530;8560;8630;8700;8730;8830
75885​	45​	Partsmax	115 Puma;125 Puma;130 Puma;140 Puma;145 Puma;150 Puma;155 Puma;160 Puma;165 Puma;170 Puma;180 Puma;185 Puma;195 Puma;200 Puma;210 Puma;MXM100;MXM110;MXM115;MXM120;MXM120 Pro;MXM130;MXM130 Pro;MXM135;MXM140;MXM140 Pro;MXM155;MXM155 Pro;MXM175;MXM175 Pro;MXM190

Output:

SKU	Brand	Numbers
65442​	Rehau	384 385 484 485XL 495 584 585
65442​	Rehau	684 685 784 785 884 885
65454​	Nike	2610 2910 3610 3910 4110 4610 5110 5610 5635
65454​	Nike	5640 5640 6410 6610 6635 6640 6640 6710 6810
65454​	Nike	7410 7610 7635 7710 7740 7740 7810 7840 7840
65454​	Nike	7910 8000 8210 8240 8240 8260 8340 8340 8360
65454​	Nike	8530 8560 8630 8700 8730 8830
75885​	Partsmax	115 Puma 125 Puma 130 Puma 140 Puma 145 Puma
75885​	Partsmax	150 Puma 155 Puma 160 Puma 165 Puma 170 Puma
75885​	Partsmax	180 Puma 185 Puma 195 Puma 200 Puma 210 Puma
75885​	Partsmax	MXM100 MXM110 MXM115 MXM120 MXM120 Pro MXM130
75885​	Partsmax	MXM130 Pro MXM135 MXM140 MXM140 Pro MXM155
75885​	Partsmax	MXM155 Pro MXM175 MXM175 Pro MXM190

Hopefully this works.

 

[rlv01]

Try this.

Sub ParseNumbers()
    Dim WB As Workbook
    Dim WS As Worksheet, DestWS As Worksheet
    Dim rng As Range, R As Range
    Dim I As Long, J As Long, SLen As Long, SKU As Long, CCnt As Long
    Dim S As String, S1 As String, Brand As String
    Dim SA As Variant
    
    Set WB = ThisWorkbook
    On Error Resume Next
    Set WS = WB.Worksheets("Data")
    Set DestWS = WB.Worksheets("Results")
    On Error GoTo 0
    
    If WS Is Nothing Or DestWS Is Nothing Then
        MsgBox "One or more required worksheets not found", vbCritical
        Exit Sub
    End If
    With WS
        Set rng = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
    End With
    
    With DestWS
        .Cells.Clear
        WS.Range("A1:D1").Copy .Range("A1")
        .Columns("B").Delete
    End With
    
    With DestWS.Range("A1")
        J = 1
        For Each R In rng
            SKU = R.Value
            CCnt = Trim(R.Offset(0, 1).Value)
            Brand = Trim(R.Offset(0, 2).Value)
            S = Application.Trim(R.Offset(0, 3).Value)
            SA = Split(Replace(S, ";", "; "), ";")
            
            S = ""
            S1 = ""
            For I = 0 To UBound(SA)
                S1 = S
                S = S & SA(I)
                SLen = Len(S)
                If SLen > CCnt Then
                    .Offset(J, 0).Value = SKU
                    .Offset(J, 1).Value = Brand
                    .Offset(J, 2).Value = S1
                    J = J + 1
                    S = Trim(SA(I))
                End If
            Next I
            If S <> "" Then
                .Offset(J, 0).Value = SKU
                .Offset(J, 1).Value = Brand
                .Offset(J, 2).Value = Trim(S)
                J = J + 1
            End If
        Next R
    End With
    DestWS.Columns.AutoFit
End Sub

 

[pgc01]

Hi

Try also with your example, with result in columns F:H

Sub SplitCount()
Dim r As Range, rC As Range
Dim regex As Object, regexMatches As Object, regexMatch As Object
Dim lRow As Long

Set r = Range("A2", Range("A" & Rows.Count).End(xlUp))
Set regex = CreateObject("VBScript.RegExp")
regex.Global = True
lRow = 2

For Each rC In r
    regex.Pattern = "(.{1," & rC.Offset(0, 1).Value & "})(;|$)"
    Set regexMatches = regex.Execute(rC.Offset(0, 3).Value)
    For Each regexMatch In regexMatches
        Range("F" & lRow).Value = rC.Value
        Range("G" & lRow).Value = rC.Offset(0, 2).Value
        Range("H" & lRow).Value = Replace(regexMatch.submatches(0), ";", " ")
        lRow = lRow + 1
    Next regexMatch
Next rC

End Sub

 

[Peter_SSs]

This would be my method. It assumes data in columns A:D of Sheet1 and puts the results in columns A:C of Sheet2

Sub Split_Text()
  Dim a As Variant, b As Variant
  Dim i As Long, k As Long, LineChars As Long
  Dim s As String
  
  a = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("D" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To Rows.Count, 1 To 3)
  For i = 1 To UBound(a)
    s = Replace(a(i, 4), ";", " ")
    LineChars = a(i, 2)
    Do Until Len(s) = 0
      k = k + 1
      b(k, 1) = a(i, 1): b(k, 2) = a(i, 3): b(k, 3) = RTrim(Left(s, InStrRev(s & Space(LineChars), " ", LineChars + 1) - 1))
      s = Mid(s, Len(b(k, 3)) + 2)
    Loop
  Next i
  With Sheets("Sheet2").Columns("A:C")
    .Clear
    .Resize(k).Offset(1).Value = b
    .Rows(1).Value = Array("SKU", "Brand", "Numbers")
    .EntireColumn.AutoFit
  End With
End Sub

My sample data

eagiordano.xlsm
	A	B	C	D
1	SKU	Character Count	Brand	Numbers
2	65442	30	Rehau	384;385;484;485XL;495;584;585;684;685;784;785;884;885
3	65454	44	Nike	2610;2910;3610;3910;4110;4610;5110;5610;5635;5640;5640;6410;6610;6635;6640;6640;6710;6810;7410;7610;7635;7710;7740;7740;7810;7840;7840;7910;8000;8210;8240;8240;8260;8340;8340;8360;8530;8560;8630;8700;8730;8830
4	75885	45	Partsmax	115 Puma;125 Puma;130 Puma;140 Puma;145 Puma;150 Puma;155 Puma;160 Puma;165 Puma;170 Puma;180 Puma;185 Puma;195 Puma;200 Puma;210 Puma;MXM100;MXM110;MXM115;MXM120;MXM120 Pro;MXM130;MXM130 Pro;MXM135;MXM140;MXM140 Pro;MXM155;MXM155 Pro;MXM175;MXM175 Pro;MXM190
Sheet1

Results

eagiordano.xlsm
	A	B	C
1	SKU	Brand	Numbers
2	65442	Rehau	384 385 484 485XL 495 584 585
3	65442	Rehau	684 685 784 785 884 885
4	65454	Nike	2610 2910 3610 3910 4110 4610 5110 5610 5635
5	65454	Nike	5640 5640 6410 6610 6635 6640 6640 6710 6810
6	65454	Nike	7410 7610 7635 7710 7740 7740 7810 7840 7840
7	65454	Nike	7910 8000 8210 8240 8240 8260 8340 8340 8360
8	65454	Nike	8530 8560 8630 8700 8730 8830
9	75885	Partsmax	115 Puma 125 Puma 130 Puma 140 Puma 145 Puma
10	75885	Partsmax	150 Puma 155 Puma 160 Puma 165 Puma 170 Puma
11	75885	Partsmax	180 Puma 185 Puma 195 Puma 200 Puma 210 Puma
12	75885	Partsmax	MXM100 MXM110 MXM115 MXM120 MXM120 Pro MXM130
13	75885	Partsmax	MXM130 Pro MXM135 MXM140 MXM140 Pro MXM155
14	75885	Partsmax	MXM155 Pro MXM175 MXM175 Pro MXM190
Sheet2

 

[eagiordano]

Thanks for the replies @rlv01 @pgc01 @Peter_SSs. Very helpful and will all work. Much appreciated.

 

[Peter_SSs]

You're welcome. Glad we could help. Thanks for the follow-up.

Is your data fairly small? There could be some significant differences in processing time if you have much data.

 

[eagiordano]

Thanks @Peter_SSs. We run them in batches so it depends on the batch. Currently I have only tested on a small batch so I am yet to find out. I will however bear that in mind though.