Macro to a split a column of data to adjacent columns as headers

[RAM72]

Macro to a split a column of data to adjacent columns as headers.

It is data of 1000 rows which is done manually, so looking for a macro

See attached for ease of understanding
Item No.Hs Code
00139172900
002
39172900
003
39173300
004
39173900
005
39173900
006
39174000
007
39191000
008
39191000
009
39199000
10
39209900

 

[eibi]

Is a macro a necessity?

What if you paste in B4: =IF(LEN(B2)>0,A4,"")

And in C4: =IF(LEN(C2)>0,A5,"")

And drag down...(see attached).

 

[YasserKhalil]

Try this code

Sub Split()
    Dim Arr, Temp, I As Long, P As Long
    Arr = Range("A4:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    ReDim Temp(1 To UBound(Arr) / 2, 1 To 2)
    For I = LBound(Arr) To UBound(Arr) Step 2
        P = P + 1
        Temp(P, 1) = Arr(I, 1)
        Temp(P, 2) = Arr(I + 1, 1)
    Next I
    Range("C4").Resize(UBound(Temp, 1), UBound(Temp, 2)).Value = Temp
End Sub

 

[RAM72]

Is a macro a necessity?

What if you paste in B4: =IF(LEN(B2)>0,A4,"")

And in C4: =IF(LEN(C2)>0,A5,"")

And drag down...(see attached).

thanks for help

 

[RAM72]

Try this code

Sub Split()
    Dim Arr, Temp, I As Long, P As Long
    Arr = Range("A4:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    ReDim Temp(1 To UBound(Arr) / 2, 1 To 2)
    For I = LBound(Arr) To UBound(Arr) Step 2
        P = P + 1
        Temp(P, 1) = Arr(I, 1)
        Temp(P, 2) = Arr(I + 1, 1)
    Next I
    Range("C4").Resize(UBound(Temp, 1), UBound(Temp, 2)).Value = Temp
End Sub

Thanks workings but I was looking as annexed as the data is bit complicated to explain see sheet final as there are lot of rows to adjust

 

[YasserKhalil]

Try this code
The result will be for sheet 1 .. I mean sheet 1 which is the raw data for you will be affected by this code

Sub Test()
    Dim I As Long
   
    Columns("B:C").Insert Shift:=xlToRight
    For I = 5 To Cells(Rows.Count, 1).End(xlUp).Row Step 2
        With Cells(I, 1)
            Cells(I, 1).Offset(-1, 1).Value = Val(Cells(I, 1).Offset(-1))
            Cells(I, 1).Offset(-1, 2).Value = .Value
            .ClearContents
        End With
    Next I
   
    Range("B2").Value = "Item No."
    Range("C2").Value = "Hs Code"
    Range("A4:A" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

 

[jindon]

RAM72

Why you always ask this way?
Is is just wasting time for us and for you...

Ask the question with EXACT what you have and what you want in the first place.

Sub test()
    Application.ScreenUpdating = False
    With Sheets("sheet1")
        .Columns("b:c").Insert
        .[b2:c2].Value = [{"Item No.","Hs Code"}]
        With .Range("a4", .Range("a" & Rows.Count).End(xlUp)).Offset(, 1)
            With .Resize(, 2)
                .NumberFormat = ""
                .Value = [{"=if(len(a4)=3,a4,"""")", "=if(len(a5)>3,a5,"""")"}]
                .Value = .Value
            End With
            .SpecialCells(4).EntireRow.Delete
        End With
    End With
    Application.ScreenUpdating = True
End Sub

 

[YasserKhalil]

That's amazing and awesome Mr. Jindon.
Thank you very much for sharing us this great solution

 

[RAM72]

Try this code
The result will be for sheet 1 .. I mean sheet 1 which is the raw data for you will be affected by this code

Sub Test()
    Dim I As Long
  
    Columns("B:C").Insert Shift:=xlToRight
    For I = 5 To Cells(Rows.Count, 1).End(xlUp).Row Step 2
        With Cells(I, 1)
            Cells(I, 1).Offset(-1, 1).Value = Val(Cells(I, 1).Offset(-1))
            Cells(I, 1).Offset(-1, 2).Value = .Value
            .ClearContents
        End With
    Next I
  
    Range("B2").Value = "Item No."
    Range("C2").Value = "Hs Code"
    Range("A4:A" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

thank you a lot again working as a charm

 

[RAM72]

RAM72

Why you always ask this way?
Is is just wasting time for us and for you...

Ask the question with EXACT what you have and what you want in the first place.

Sub test()
    Application.ScreenUpdating = False
    With Sheets("sheet1")
        .Columns("b:c").Insert
        .[b2:c2].Value = [{"Item No.","Hs Code"}]
        With .Range("a4", .Range("a" & Rows.Count).End(xlUp)).Offset(, 1)
            With .Resize(, 2)
                .NumberFormat = ""
                .Value = [{"=if(len(a4)=3,a4,"""")", "=if(len(a5)>3,a5,"""")"}]
                .Value = .Value
            End With
            .SpecialCells(4).EntireRow.Delete
        End With
    End With
    Application.ScreenUpdating = True
End Sub

I am finding solution to automate my daily tasks.

So now I go straight what I am looking but again thank you for the code