Macro to split data to their respective columns

[RAM72]

Need a macro to split data in their respective columns as per attached file

The data goes up to 20000 rows

One column is always 8 digits the second column is alpha numeric , the third always 2 alphabet and the fouth column is alphanumerical .The word total is ignored

 

[Marc L]

Code to paste to worksheet module :​

Sub Demo1()
    VA = Cells(1).CurrentRegion.Value
    ReDim VR(2 To UBound(VA), 1 To 4)
For R& = 2 To UBound(VA)
                                         SP = Split(VA(R, 1))
                                   VR(R, 1) = SP(0)
                                   VR(R, 2) = SP(1)
                                   VR(R, 3) = SP(UBound(SP) - 2)
                                   VR(R, 4) = SP(UBound(SP) - 1)
    For C% = 2 To UBound(SP) - 3:  VR(R, 2) = VR(R, 2) & " " & SP(C):  Next
Next
    [A2:D2].Resize(UBound(VR) - 1).Value = VR
    Cells(1).CurrentRegion.Columns.AutoFit
End Sub

Do you like it ? So thanks to click on bottom right Like !
​

 

[Luke M]

Could do this with just formulas, but here you go.

Sub WriteFormulas()
Dim lastRow As Long
Dim ws As Worksheet

'Which sheet to work on?
Set ws = ActiveSheet

Application.ScreenUpdating = True
With ws
    'Find the last row of data
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   
    'Build the formulas
    .Range("B2:B" & lastRow).Formula = "=1*LEFT(A2,8)"
    .Range("C2:C" & lastRow).Formula = "=MID(LEFT(A2,FIND("" ""&D9&"" "",A2)-1),10,999)"
    .Range("D2:D" & lastRow).Formula = "=LEFT(RIGHT(A2,14),2)"
    .Range("E2:E" & lastRow).Formula = "=LEFT(RIGHT(A2,11),5)*1"
   
    'If you want static values, use this bit
    With .Range("B2:E" & lastRow)
        .Copy
        .PasteSpecial xlPasteValues
    End With
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

 

[RAM72]

Could do this with just formulas, but here you go.

Sub WriteFormulas()
Dim lastRow As Long
Dim ws As Worksheet

'Which sheet to work on?
Set ws = ActiveSheet

Application.ScreenUpdating = True
With ws
    'Find the last row of data
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
  
    'Build the formulas
    .Range("B2:B" & lastRow).Formula = "=1*LEFT(A2,8)"
    .Range("C2:C" & lastRow).Formula = "=MID(LEFT(A2,FIND("" ""&D9&"" "",A2)-1),10,999)"
    .Range("D2:D" & lastRow).Formula = "=LEFT(RIGHT(A2,14),2)"
    .Range("E2:E" & lastRow).Formula = "=LEFT(RIGHT(A2,11),5)*1"
  
    'If you want static values, use this bit
    With .Range("B2:E" & lastRow)
        .Copy
        .PasteSpecial xlPasteValues
    End With
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Hi Luke

Tested code, working

but giving in column C header description # value!

Some adjustments needed in the formula column C

Coding No Description Qty Po
39173900 #VALUE! CN 14178
39173900 #VALUE! CN 14216
39174000 #VALUE! CN 14216
39189000 #VALUE! FR 13691

 

[RAM72]

Could do this with just formulas, but here you go.

Sub WriteFormulas()
Dim lastRow As Long
Dim ws As Worksheet

'Which sheet to work on?
Set ws = ActiveSheet

Application.ScreenUpdating = True
With ws
    'Find the last row of data
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
  
    'Build the formulas
    .Range("B2:B" & lastRow).Formula = "=1*LEFT(A2,8)"
    .Range("C2:C" & lastRow).Formula = "=MID(LEFT(A2,FIND("" ""&D9&"" "",A2)-1),10,999)"
    .Range("D2:D" & lastRow).Formula = "=LEFT(RIGHT(A2,14),2)"
    .Range("E2:E" & lastRow).Formula = "=LEFT(RIGHT(A2,11),5)*1"
  
    'If you want static values, use this bit
    With .Range("B2:E" & lastRow)
        .Copy
        .PasteSpecial xlPasteValues
    End With
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Code to paste to worksheet module :​

Sub Demo1()
    VA = Cells(1).CurrentRegion.Value
    ReDim VR(2 To UBound(VA), 1 To 4)
For R& = 2 To UBound(VA)
                                         SP = Split(VA(R, 1))
                                   VR(R, 1) = SP(0)
                                   VR(R, 2) = SP(1)
                                   VR(R, 3) = SP(UBound(SP) - 2)
                                   VR(R, 4) = SP(UBound(SP) - 1)
    For C% = 2 To UBound(SP) - 3:  VR(R, 2) = VR(R, 2) & " " & SP(C):  Next
Next
    [A2:D2].Resize(UBound(VR) - 1).Value = VR
    Cells(1).CurrentRegion.Columns.AutoFit
End Sub

Do you like it ? So thanks to click on bottom right Like !
​

Thanks Marc working perfectly

 

[Luke M]

I goofed.
code line correction:

.Range("C2:C" & lastRow).Formula = "=MID(LEFT(A2,FIND("" ""&D2&"" "",A2)-1),10,999)"

Accidentally had D9 rather than D2. Doh!

 

[RAM72]

I goofed.
code line correction:

.Range("C2:C" & lastRow).Formula = "=MID(LEFT(A2,FIND("" ""&D2&"" "",A2)-1),10,999)"

Accidentally had D9 rather than D2. Doh!

Thank you LUKE for your help and assistance