Table from H***

[johnfrib]

Hi gurus

We have an item table consisting of around 100k lines, the description field is only 30 characters and have been used creatively during the years.

My challenge now is to split the description field to make it more groupable.


One like can look like this:
MA NOVA PLUS 16 10002000 271

The logic of the naming is something like this.
First MA NOVA PLUS is the name, 16 is the year 1000 is the with and 2000 is the length 271 is the color.
This next line
MA SIGNATUR3 14 21002100FXF540

Still the name id MA SIGNATUR3, year 14, 2100 with, 2100 length FX = Extra firm, F = firm and 540 color.

Tried to use
=LEFT(E2;FIND("1";E2)+2) to separate text to and include year but the data is not consistent enough.

And many other formulas found on the net without any luck.

Is it possible to do this without pre-sorting of the data, or do I need to go the long way?

Adding a few of the variants at the end of this post.
Any help would be appreciated.

John

MA C4 17 09002000F 000
MA SIGNATUR1 11 07502000M 527
MA SIGNATUR1 20 07502000M 527
MA SIGNATUR2 17 07502000XF 527
MA SIGNATUR2 17 07502100XF 527
MA AMBA 18 18002000FXF 368
FIR 1/1 CONT 18 16002100FXF497
FIR 1/1 CONT 18 16002100XF 430
BASE MAJ DS16 PRO 10502100 383
BASE CARAT 16PROT 09002000 218
BASE EXACT NATUR SUP 09002000
BASE CROWN NATUR 18 10502100
BASE AMB PROTO 15 09002000 455
BASE C6 PROTO 17 09002000 528
BASE SIGNATUR6 17 09002000 564
BASE SIGNATUR6 17 09002000 565
BASE SIGNATUR3 17 14002000 561
BASE C6 17 PROTO 09002000 566
BASE AMBA 17 09002000 369
BASE C4/5 17 09002000 528
BASE C4/5 17 09002000 458
BASE C4/5 17 09002000 545
BASE C4/5 17 08002000 541
BASE C4/5 17 08002000 528
BASE C4/5 17 09002000 543
BASE EXACT NATUREL 14 09002100
BASE EXACT NATUREL 14 10502100
BASE NATUREL S 14 07502000
BASE NATUREL S 14 07502100
BASE NATUREL S 14 08002100
HYGIENEDUK 08001400
TM SAMPEL SOFTLINE I 04000400
TM SAMPEL SOFT I 12 04000300
TM SAMPEL SOFTLINE II 04000400
TM SAMPEL SOFT II 12 04000300
TM SAMPEL PREMIUM 12 04000400
TM SAMPEL SOFTLINE III04000400
TM SAMPEL SOFT III 12 04000300
TM SAMPEL TEMPSMART12 04000300
TM SAMPEL TEMPS XO 13 04000300
FABRIC GALGE 527 528
OTTOMAN SATURN 18 15000380 329
OTTOMAN SATURN 18 15000380 445
OTTOMAN SATURN 18 15000380 457
HB IND DEC INT 12 21001250 410
HB DIONE 14 15000950 527
AC SOFT PROTECT 2016 21002000
LEGS EICON PREMIUM OAK 14CM
MISTR BEDBASE OAK 180020000230
MISTR BEDBA BLACK 180020000230
CO BS DIP RC 18 09002000 462
CO BS SIGNAT 2 11 07502000 528
CO BS SIGNAT 2 11 07502100 528
CO BS C2 VELC F18 14002000 527
CO BS C2 VELC F18 10002000 527
CO BS C2 17 08002000 527
CO BS C2 17 09002000 528
CO BS C2 17 09002100 528
MA C4 17 09002000F 000
MA SIGNATUR1 11 07502000M 527
MA SIGNATUR1 20 07502000M 527
MA SIGNATUR2 17 07502000XF 527
MA SIGNATUR2 17 07502100XF 527
MA AMBA 18 18002000FXF 368
FIR 1/1 CONT 18 16002100FXF497
FIR 1/1 CONT 18 16002100XF 430
BASE MAJ DS16 PRO 10502100 383
BASE CARAT 16PROT 09002000 218
BASE EXACT NATUR SUP 09002000
BASE CROWN NATUR 18 10502100
BASE AMB PROTO 15 09002000 455
BASE C6 PROTO 17 09002000 528
BASE SIGNATUR6 17 09002000 564
BASE SIGNATUR6 17 09002000 565
BASE SIGNATUR3 17 14002000 561
BASE C6 17 PROTO 09002000 566
BASE AMBA 17 09002000 369
BASE C4/5 17 09002000 528
BASE C4/5 17 09002000 458
BASE C4/5 17 09002000 545
BASE C4/5 17 08002000 541
BASE C4/5 17 08002000 528
BASE C4/5 17 09002000 543
BASE EXACT NATUREL 14 09002100
BASE EXACT NATUREL 14 10502100
BASE NATUREL S 14 07502000
BASE NATUREL S 14 07502100
BASE NATUREL S 14 08002100
HYGIENEDUK 08001400
TM SAMPEL SOFTLINE I 04000400
TM SAMPEL SOFT I 12 04000300
TM SAMPEL SOFTLINE II 04000400
TM SAMPEL SOFT II 12 04000300
TM SAMPEL PREMIUM 12 04000400
TM SAMPEL SOFTLINE III04000400
TM SAMPEL SOFT III 12 04000300
TM SAMPEL TEMPSMART12 04000300
TM SAMPEL TEMPS XO 13 04000300
FABRIC GALGE 527 528
OTTOMAN SATURN 18 15000380 329
OTTOMAN SATURN 18 15000380 445
OTTOMAN SATURN 18 15000380 457
HB IND DEC INT 12 21001250 410
HB DIONE 14 15000950 527
AC SOFT PROTECT 2016 21002000
LEGS EICON PREMIUM OAK 14CM
MISTR BEDBASE OAK 180020000230
MISTR BEDBA BLACK 180020000230
CO BS DIP RC 18 09002000 462
CO BS SIGNAT 2 11 07502000 528
CO BS SIGNAT 2 11 07502100 528
CO BS C2 VELC F18 14002000 527
CO BS C2 VELC F18 10002000 527
CO BS C2 17 08002000 527
CO BS C2 17 09002000 528
CO BS C2 17 09002100 528
Test EXACT INSTRUCTIONE
Assembly and instr, Dynamique
Assembly and instr, Aqtive II
Assembly and instr, Flexi
Test GUARANTEE
CONTROLL LABEL
Test CONGRATULATIONS CARD
Test DREAM INSTRUCTIONE 2016
Test DREAM INSTRUCTIONE UK
SAMPLE LDDP 03000300
CO AB OPAL FH 16 09002000 358
CO AB CARAT FH 13 09002000 214
CO FIR AQ F PRO L 09002000 496
CO FIR AQ2 U PROT 09002000 496
CO DIP+ AQ1 U18 09002000 457
CO DIP AQ2 F RC18 18002000 457
CO AMB AQ2 F RC18 18002000 368
CO PRE AQ2 F RC18 18002000 366
CO PRE AQ2 F RC18 18002100 366
CO AMBA AQ2 U18 09002000 368
CO PRES AQ2 U18 09002000 366
CO PRES AQ2 U18 09002100 366
CO AMBA AQ2 U18 09002000 380
CO AMB AQ2 F RC18 18002000 380
CO DIP AQ2 F RC18 18002000 410
TEST CO SUP AQ1 F 09002000 320
CO AMBA AQ2 F15 09002000 465
CO SØMTEST SUP AQ2 F 09002000
CO FIR DRE F RC18 15002000 496
CO FIR DRE F RC18 15002100 496
CO FIR DRE F RC18 16002000 496
CO FIR DRE F RC18 16002100 496
CO FIR DRE F RC18 18002000 496
CO FIR DRE F RC18 18002100 496
CO FIR DRE F RC18 20002000 496
CO FIR DRE F RC18 20002100 496
CO FIR DRE F RC18 21002000 496
CO FIR DRE F RC18 21002100 496
CO FIR DRE F RC18 15002000 497
CO FIR DRE F RC18 15002100 497
CO FIR DRE F RC18 16002000 497
CO FIR DRE F RC18 16002100 497
CO FIR DRE F RC18 18002000 497
CO FIR DRE F RC18 18002100 497
CO FIR DRE F RC18 20002000 497
CO FIR DRE F RC18 20002100 497
CO FIR DRE F RC18 21002000 497
CO FIR DRE F RC18 21002100 497
CO AB NOVA FH 16 07502000 271
CO AB NOVA FH 16 07502100 271
CO AB NOVA FH 16 08002000 271
CO AB NOVA FH 16 08002100 271
CO AB NOVA FH 16 09002000 271
CO AB NOVA FH 16 09002100 271
CO AB NOVA FH 16 10502000 271
CO AB NOVA FH 16 10502100 271
CO AB NOVA FH 16 12002000 271
CO AB NOVA FH 16 12002100 271
CO AB NOVA FH 16 07502000 281
CO AB NOVA FH 16 07502100 281
CO AB NOVA FH 16 08002000 281
CO AB NOVA FH 16 08002100 281
CO AB NOVA FH 16 09002000 281
CO AB NOVA FH 16 09002100 281

 

[DanteAmor]

Maybe the following code can help something. Create a sheet called "Temp" and put the following structure:

	A	B	C	D	E	F	G
1	DESC	NAME	YEAR	WITH	LENGTH	LETTER	NUMBER
2

<tbody>
</tbody>

Run the next macro, Before, change in the macro "items" by the name of your sheet with the descriptions

Sub split_the_description()
    Application.ScreenUpdating = False
    Application.StatusBar = False
    '
    Set h1 = Sheets("Items")    'name sheet whit descriptions
    Set h2 = Sheets("Temp")
    h2.Rows("2:" & Rows.Count).ClearContents
    For i = 2 To h1.Range("A" & Rows.Count).End(xlUp).Row
        desc = h1.Cells(i, "A").Value
        nombre = ""
        año = ""
        w_with = ""
        w_length = ""
        
        For j = 1 To Len(desc)
            If Mid(desc, j, 1) = " " And _
               IsNumeric(Mid(desc, j + 1, 2)) And _
               Mid(desc, j + 3, 1) = " " Then
                nombre = Left(desc, j - 1)
                año = Mid(desc, j + 1, 2)
                Exit For
            End If
        Next
        For j = 1 To Len(desc)
            If Mid(desc, j, 1) = " " And _
               IsNumeric(Mid(desc, j + 1, 8)) Then
                If nombre = "" Then
                    nombre = Left(desc, j - 1)
                End If
                w_with = Mid(desc, j + 1, 4)
                w_length = Mid(desc, j + 1 + 4, 4)
                newj = j + 9
                Exit For
            End If
        Next
        cad1 = ""
        cad2 = ""
        For j = newj To Len(desc)
            If IsNumeric(Mid(desc, j, 1)) Then
                cad2 = cad2 & Mid(desc, j, 1)
            Else
                cad1 = cad1 & Mid(desc, j, 1)
            End If
        Next
        h2.Cells(i, "A").Value = h1.Cells(i, "A").Value
        h2.Cells(i, "B").Value = nombre
        h2.Cells(i, "C").Value = "'" & año
        h2.Cells(i, "D").Value = "'" & w_with
        h2.Cells(i, "E").Value = "'" & w_length
        h2.Cells(i, "F").Value = "'" & cad1
        h2.Cells(i, "G").Value = "'" & cad2
    Next
    '
    Application.ScreenUpdating = True
    Application.StatusBar = False
    MsgBox "End"
End Sub

Test and tell me.

 

[Fazza]

Looks good, Dante

I did some work too. Works OK for some items, others need more work still.
To use, select the cells you want to change, and after the code runs the result is on the RHS of the starting cells.

cheers

Sub test()


    MsgBox "select all the data" & vbCr & vbCr & "the result will paste on the RHS"


    If MsgBox("ready to go", vbYesNo + vbQuestion) = vbYes Then
    
        With Selection
            .Offset(, 1).Resize(, 5).Value = TryThis(.Cells)
        End With
        
    Else
        MsgBox "nothing done"
    End If
    
End Sub


Function TryThis(ByRef inputrng As Range) As Variant


    Dim i As Long
    Dim lYearPosition As Long
    
    Dim sEntry As String
    Dim Ans As Variant
    Dim Inp As Variant
    
    Inp = inputrng.Value


    ReDim Ans(1 To 1000000, 1 To 5)
    
    For i = 1 To inputrng.Rows.Count
    
        sEntry = Trim$(Inp(i, 1))
        lYearPosition = PositionOf2DigitYear(sEntry)
        
        If lYearPosition = 0 Then 'Did NOT find 2 digit year something like "something YY etc"
            
            Ans(i, 1) = sEntry
            
            'if ends in space then three characters, populate fifth field
            If sEntry Like "* [0-9][0-9][0-9]" Then
                Ans(i, 1) = Left$(sEntry, Len(sEntry) - 4)
                Ans(i, 5) = Right$(sEntry, 3)
            End If
            
            'if end in space then eight characters, populate third & fourth fields
            sEntry = Ans(i, 1)
            If sEntry Like "* [0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]" Then
                Ans(i, 1) = Left$(sEntry, Len(sEntry) - 9)
                Ans(i, 3) = Mid$(sEntry, Len(sEntry) - 8 + 1, 4)
                Ans(i, 4) = Right$(sEntry, 4)
            End If
            
        Else
            '2 digit date found. something like "something YY etc"
            Ans(i, 1) = Left$(sEntry, lYearPosition - 2)
            Ans(i, 2) = Mid$(sEntry, lYearPosition, 2)
            Ans(i, 3) = Mid$(sEntry, lYearPosition + 3, 4)
            Ans(i, 4) = Mid$(sEntry, lYearPosition + 7, 4)
            Ans(i, 5) = Mid$(sEntry, lYearPosition + 11, 255)
        End If
        
    Next i
    
    TryThis = Ans


End Function


Function PositionOf2DigitYear(ByVal sEntry As String) As Long
    'Look for 2 digit year in form " xx ". So must have leading & trailing spaces
    
    Dim i As Long
    
    PositionOf2DigitYear = 0
    
    If sEntry Like "* [0-9][0-9] *" Then
        For i = 1 To Len(sEntry)
            If Mid$(sEntry, i, 4) Like " [0-9][0-9] " Then Exit For
        Next i
        PositionOf2DigitYear = i + 1
    End If
    
End Function

 

[Fazza]

I missed the letter field near the end. Updated code follows.

Sub test()

    MsgBox "select all the data" & vbCr & vbCr & "the result will paste on the RHS"


    If MsgBox("ready to go", vbYesNo + vbQuestion) = vbYes Then
    
        With Selection
            .Offset(, 1).Resize(, 6).Value = TryThis(.Cells)
        End With
        
    Else
        MsgBox "nothing done"
    End If
    
End Sub


Function TryThis(ByRef inputrng As Range) As Variant


    Dim i As Long
    Dim lYearPosition As Long
    
    Dim sEntry As String
    Dim Ans As Variant
    Dim Inp As Variant
    
    Inp = inputrng.Value


    ReDim Ans(1 To 1000000, 1 To 6)
    
    For i = 1 To inputrng.Rows.Count
    
        sEntry = Trim$(Inp(i, 1))
        lYearPosition = PositionOf2DigitYear(sEntry)
        
        If lYearPosition = 0 Then 'Did NOT find 2 digit year something like "something YY etc"
            
            Ans(i, 1) = sEntry
            
            'if ends in space then three characters, populate fifth field
            If sEntry Like "* [0-9][0-9][0-9]" Then
                Ans(i, 1) = Left$(sEntry, Len(sEntry) - 4)
                Ans(i, 6) = "'" & Right$(sEntry, 3)
            End If
            
            'if end in space then eight characters, populate third & fourth fields
            sEntry = Ans(i, 1)
            If sEntry Like "* [0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]" Then
                Ans(i, 1) = Left$(sEntry, Len(sEntry) - 9)
                Ans(i, 3) = Mid$(sEntry, Len(sEntry) - 8 + 1, 4)
                Ans(i, 4) = Right$(sEntry, 4)
            End If
            
        Else
            '2 digit date found. something like "something YY etc"
            Ans(i, 1) = Left$(sEntry, lYearPosition - 2)
            Ans(i, 2) = Mid$(sEntry, lYearPosition, 2)
            Ans(i, 3) = Mid$(sEntry, lYearPosition + 3, 4)
            Ans(i, 4) = Mid$(sEntry, lYearPosition + 7, 4)
            Ans(i, 6) = "'" & Mid$(sEntry, lYearPosition + 11, 255)
            
            sEntry = Ans(i, 6)
            If Len(sEntry) > 3 Then
                Ans(i, 5) = Trim$(Left$(sEntry, Len(sEntry) - 3))
                Ans(i, 6) = "'" & Right$(sEntry, 3)
            End If
            
        End If
        
        'check again for year identifiers where currently blank
        If Len(Ans(i, 2)) = 0 Then
            sEntry = Ans(i, 1)
            
            If sEntry Like "*[A-Z][0-9][0-9]" Then
                Ans(i, 2) = Right$(sEntry, 2)
                Ans(i, 1) = Left$(sEntry, Len(sEntry) - 2)
            ElseIf sEntry Like "* [0-9][0-9][0-9][0-9]" Then
                Ans(i, 2) = Right$(sEntry, 4)
                Ans(i, 1) = Left$(sEntry, Len(sEntry) - 5)
            End If
            
        End If
        
    Next i
    
    TryThis = Ans


End Function


Function PositionOf2DigitYear(ByVal sEntry As String) As Long
    'Look for 2 digit year in form " YY #". So must have leading & trailing spaces then number
    
    Dim i As Long
    
    PositionOf2DigitYear = 0
    
    If sEntry Like "* [0-9][0-9] [0-9]*" Then
        For i = 1 To Len(sEntry)
            If Mid$(sEntry, i, 5) Like " [0-9][0-9] [0-9]" Then Exit For
        Next i
        PositionOf2DigitYear = i + 1
    End If
    
End Function

 

[Fazza]

minor revision. cheers

Sub test()

    MsgBox "select all the data" & vbCr & vbCr & "the result will paste on the RHS"


    If MsgBox("ready to go", vbYesNo + vbQuestion) = vbYes And Selection.Rows.Count > 1 Then
        With Selection
            .Offset(, 1).Resize(, 6).Value = TryThis(.Cells)
        End With
    Else
        MsgBox "nothing done"
    End If
    
End Sub


Function TryThis(ByRef inputrng As Range) As Variant


    Dim i As Long
    Dim lYearPosition As Long
    
    Dim sEntry As String
    Dim Ans As Variant
    Dim Inp As Variant
    
    Inp = inputrng.Value


    ReDim Ans(1 To 1000000, 1 To 6)
    
    For i = 1 To inputrng.Rows.Count
    
        sEntry = Trim$(Inp(i, 1))
        lYearPosition = PositionOf2DigitYear(sEntry)
        
        If lYearPosition = 0 Then 'Did NOT find 2 digit year something like "something YY etc"
            
            Ans(i, 1) = sEntry
            
            'if ends in space then three characters, populate sixth field
            If sEntry Like "* [0-9][0-9][0-9]" Then
                Ans(i, 1) = Left$(sEntry, Len(sEntry) - 4)
                Ans(i, 6) = "'" & Right$(sEntry, 3)
            End If
            
            'if end in space then eight characters, populate third & fourth fields
            sEntry = Ans(i, 1)
            If sEntry Like "* [0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]" Then
                Ans(i, 1) = Left$(sEntry, Len(sEntry) - 9)
                Ans(i, 3) = Mid$(sEntry, Len(sEntry) - 8 + 1, 4)
                Ans(i, 4) = Right$(sEntry, 4)
            End If
            
        Else
            '2 digit date found. something like "something YY etc"
            Ans(i, 1) = Left$(sEntry, lYearPosition - 2)
            Ans(i, 2) = Mid$(sEntry, lYearPosition, 2)
            Ans(i, 3) = Mid$(sEntry, lYearPosition + 3, 4)
            Ans(i, 4) = Mid$(sEntry, lYearPosition + 7, 4)
            Ans(i, 6) = "'" & Mid$(sEntry, lYearPosition + 11, 255)
            
            sEntry = Ans(i, 6)
            If Len(sEntry) > 3 Then
                Ans(i, 5) = Trim$(Left$(sEntry, Len(sEntry) - 3))
                Ans(i, 6) = "'" & Right$(sEntry, 3)
            End If
            
        End If
        
        'check again for year identifiers where currently blank
        If Len(Ans(i, 2)) = 0 Then
            sEntry = Ans(i, 1)
            If sEntry Like "*[A-Z][0-9][0-9]" Then 'if it looks like ends in year YY
                Ans(i, 2) = Right$(sEntry, 2)
                Ans(i, 1) = Left$(sEntry, Len(sEntry) - 2)
            ElseIf sEntry Like "* [0-9][0-9][0-9][0-9]" Then 'if it looks like ends in year YYYY
                Ans(i, 1) = Left$(sEntry, Len(sEntry) - 5)
                Ans(i, 2) = Right$(sEntry, 4)
            ElseIf sEntry Like "*[A-Z][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]" Then 'if it looks like ends in dimensions
                Ans(i, 1) = Left$(sEntry, Len(sEntry) - 8)
                Ans(i, 3) = Mid$(sEntry, Len(sEntry) - 8 + 1, 4)
                Ans(i, 4) = Right$(sEntry, 4)
            ElseIf sEntry Like "* [0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]" Then 'if it looks like ends in dimensions
                Ans(i, 1) = Left$(sEntry, Len(sEntry) - 12)
                Ans(i, 3) = Mid$(sEntry, Len(sEntry) - 12 + 1, 4)
                Ans(i, 4) = Mid$(sEntry, Len(sEntry) - 8 + 1, 4)
                Ans(i, 5) = Mid$(sEntry, Len(sEntry) - 4 + 1, 1)
                Ans(i, 6) = Right$(sEntry, 3)
            End If
            
        End If
        
    Next i
    
    TryThis = Ans


End Function


Function PositionOf2DigitYear(ByVal sEntry As String) As Long
    'Look for 2 digit year in form " YY #". So must have leading & trailing spaces then number
    
    Dim i As Long
    
    PositionOf2DigitYear = 0
    
    If sEntry Like "* [0-9][0-9] [0-9]*" Then
        For i = 1 To Len(sEntry)
            If Mid$(sEntry, i, 5) Like " [0-9][0-9] [0-9]" Then Exit For
        Next i
        PositionOf2DigitYear = i + 1
    End If
    
End Function

 

[johnfrib]

Thank you for your work and input, this code solves a lot of them, and gives me a good base to work forward on.

Cheers

 

[DanteAmor]

Im glad to help you!