macro to trim - split mixed numbers and text to their respective headers

[RAM72]

Data recieved from an interface need a macro to split data to their respective headers .

The first part is always numerical but may contain 5 , 6 ,7 , 8 or 9 digits maximum,
the second header is is mixed alphanumerical and the third header is always 2 alphabet but some may have no data.

See annexed .

The list is exhaustive to 5000 rows minimum.

Can anyone help

 

[Luke M]

Formula for Tariff in B2
=LEFT(A2,FIND(" ",A2)-1)

Formula for Description in C2:
=TRIM(SUBSTITUTE(IF(D2="",A2,LEFT(A2,LEN(A2)-3)),B2,""))

Formula for Origin in D2:
=IF(LEFT(RIGHT(A2,3),1)=" ",RIGHT(A2,2),"")

Produces this output:

 

[jindon]

VBA

Sub test()
    Dim a, i As Long, x
    With Cells(1).CurrentRegion.Offset(1)
        .Columns("b:d").ClearContents
        a = .Value
        For i = 1 To UBound(a, 1)
            If a(i, 1) Like "* *" Then
                x = Split(a(i, 1))
                If x(UBound(x)) Like "[A-Z][A-Z]" Then
                    a(i, 4) = x(UBound(x))
                    ReDim Preserve x(UBound(x) - 1)
                End If
                a(i, 2) = Split(Join(x), " ", 2)(0)
                a(i, 3) = Split(Join(x), " ", 2)(1)
            End If
        Next
        .Value = a
    End With
End Sub

 

[RAM72]

VBA

Sub test()
    Dim a, i As Long, x
    With Cells(1).CurrentRegion.Offset(1)
        .Columns("b:d").ClearContents
        a = .Value
        For i = 1 To UBound(a, 1)
            If a(i, 1) Like "* *" Then
                x = Split(a(i, 1))
                If x(UBound(x)) Like "[A-Z][A-Z]" Then
                    a(i, 4) = x(UBound(x))
                    ReDim Preserve x(UBound(x) - 1)
                End If
                a(i, 2) = Split(Join(x), " ", 2)(0)
                a(i, 3) = Split(Join(x), " ", 2)(1)
            End If
        Next
        .Value = a
    End With
End Sub

Tested ok , however another insight , the data is found on columnD, column E containe data not required , breakdown to appear on column F, G,H.

What part of macro should be amended

Thanks

 

[RAM72]

Formula for Tariff in B2
=LEFT(A2,FIND(" ",A2)-1)

Formula for Description in C2:
=TRIM(SUBSTITUTE(IF(D2="",A2,LEFT(A2,LEN(A2)-3)),B2,""))

Formula for Origin in D2:
=IF(LEFT(RIGHT(A2,3),1)=" ",RIGHT(A2,2),"")

Produces this output:
View attachment 27618

Thanks working

Data found on Column D , breakdown data should appear in column F,G,H.

Thanks to advise

 

[jindon]

Sub test()
    Dim a, i As Long, x
    With Range("d1", Range("d" & Rows.Count).End(xlUp)).Resize(, 5)
        .Columns("c:e").ClearContents
        a = .Value
        For i = 1 To UBound(a, 1)
            If a(i, 1) Like "* *" Then
                x = Split(a(i, 1))
                If x(UBound(x)) Like "[A-Z][A-Z]" Then
                    a(i, 5) = x(UBound(x))
                    ReDim Preserve x(UBound(x) - 1)
                End If
                a(i, 3) = Split(Join(x), " ", 2)(0)
                a(i, 4) = Split(Join(x), " ", 2)(1)
            End If
        Next
        .Value = a
    End With
End Sub

 

[RAM72]

Thanks Jindon
Working

Could you adjust the code headers so that it puts the Tariff Description Origin appears in row1
also there are several sheets Can you adjust so that it process the break down in all automatically.

Actually I have to this sheet by sheet

 

[jindon]

I don't work with pictures.

If you upload a workbook with EXACT before/after, I will adjust the code.

 

[RAM72]

I don't work with pictures.

If you upload a workbook with EXACT before/after, I will adjust the code.

See attached as per previous message file before and file after expected results
Note sheets may reach up 40 to 50 sheets or more
Hope it helps to see more clearly

 

[jindon]

try

Sub test()
    Dim ws As Worksheet, a, i As Long, x
    For Each ws In Worksheets
        With ws.Cells(1).CurrentRegion.Resize(, 8)
            .Columns("f:h").ClearContents
            [f1:h1].Value = [{"Tariff","DESCRIPTION","Origin"}]
            a = .Value
            For i = 1 To UBound(a, 1)
                If a(i, 4) Like "* *" Then
                    x = Split(a(i, 4))
                    If x(UBound(x)) Like "[A-Z][A-Z]" Then
                        a(i, 8) = x(UBound(x))
                        ReDim Preserve x(UBound(x) - 1)
                    End If
                    a(i, 6) = Split(Join(x), " ", 2)(0)
                    a(i, 7) = Split(Join(x), " ", 2)(1)
                End If
            Next
            .Value = a
        End With
    Next
End Sub

 

[RAM72]

Thanks Jindon for assistance