Splitting data from one column into other 4 columns in excel

[ramesh kola]

Dear All ,

I have been searching for a VBA code on the internet to split some values from 1 column into the 4 different columns

Each record has 4 different codes however they are placed into single cell instead of 4 columns

For Example

Column X has codes as 20/40/20B/40B now i want split into below format

20
40
2B
4B

Macro_Test.xlsm

I'm attaching excel with input and output tabs. Please help me to solve this

I don't know too much about VBA but I'm learning..

Your help would be much appreciated ..

[Bob Phillips]

Public Sub ShareRows()
Dim codes As Variant
Dim lastrow As Long
Dim numrows As Long
Dim i As Long

    Application.ScreenUpdating = False

    With ActiveSheet
    
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = lastrow To 2 Step -1
        
            codes = Split(.Cells(i, "P"), "/")
            numrows = UBound(codes) - LBound(codes)
            If numrows > 0 Then
            
                .Rows(i + 1).Resize(numrows).Insert
                .Rows(i).Copy .Cells(i, "A").Resize(numrows + 1)
                .Cells(i, "P").Resize(numrows + 1) = Application.Transpose(codes)
            End If
        Next i
    End With
    
    Application.ScreenUpdating = True
End Sub

[Tom Jones]

@xld,

I think OP want result in other sheet.
Thanks.

[ramesh kola]

Thanks Tom..!!!

your help is much appreciated.

It's worked like a charm. By the by can also help me on output results should copy to new sheet. Thanks in advance

[ramesh kola]

Thanks Tom..!!!

your help is much appreciated.

It's worked like a charm. By the by can also help me on output results should copy to new sheet. Thanks in advance

[Bob Phillips]

Public Sub ShareRows()
Dim sh As Worksheet
    Dim codes As Variant
    Dim lastrow As Long
    Dim numrows As Long
    Dim i As Long
     
    Application.ScreenUpdating = False
    
    Set sh = CreateSheet(SheetName:="Output")
    ActiveSheet.Cells.Copy sh.Cells
    
    With sh
         
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = lastrow To 2 Step -1
             
            codes = Split(.Cells(i, "P"), "/")
            numrows = UBound(codes) - LBound(codes)
            If numrows > 0 Then
                 
                .Rows(i + 1).Resize(numrows).Insert
                .Rows(i).Copy .Cells(i, "A").Resize(numrows + 1)
                .Cells(i, "P").Resize(numrows + 1) = Application.Transpose(codes)
            End If
        Next i
    End With
     
    Application.ScreenUpdating = True
End Sub

Private Function CreateSheet(ByVal SheetName As String) As Worksheet
Dim This As Worksheet

    Set This = ActiveSheet
    
    On Error Resume Next
    ThisWorkbook.Worksheets(SheetName).Delete
    On Error GoTo 0
    
    With ThisWorkbook
    
        .Worksheets.Add after:=.Worksheets(.Worksheets.Count)
    End With
    
    Set CreateSheet = ActiveSheet
    CreateSheet.Name = SheetName
    
    This.Activate
End Function

[ramesh kola]

Thanks Tom!!

You are just Awesome.. Thanks for your help

[Bob Phillips]

Thanks Tom!!

You are just Awesome.. Thanks for your help

Tom is Bob!

[Tom Jones]

Thanks Tom!!

You are just Awesome.. Thanks for your help

No, no.

All merits goes to Bob.

[ramesh kola]

Tom is Bob!

Hi Sir!!

I have a new requirement for my macro in output sheet i need a new column between P(Code) - Q(Service)

like - P(Code)|Q(Type)|R(Service)

in new column (Type)

it should map some types if P column as 20 then in Q column should map with 2000

1. if P column as 20 then in Q column should map with 2000
2. if P column as 40 then in Q column should map with 4000
3. if P column as 2B then in Q column should map with 2B00


like this . I have tried some vlookup concepts but it's not worked. Please help me...!!! Thanks in advance..!!

[mdmackillop]

Can you post an Output sheet showing desired result. I'm not clear what goes into Type

[ramesh kola]

Can you post an Output sheet showing desired result. I'm not clear what goes into Type

Hi

required Output sheet attached

[mdmackillop]

With sh
        .Range("Q1").EntireColumn.Insert
        .Range("Q1") = "Type"
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = lastrow To 2 Step -1
            codes = Split(.Cells(i, "P"), "/")
            numrows = UBound(codes) - LBound(codes)
            If numrows > 0 Then
                .Rows(i + 1).Resize(numrows).Insert
                .Rows(i).Copy .Cells(i, "A").Resize(numrows + 1)
                .Cells(i, "P").Resize(numrows + 1) = Application.Transpose(codes)
                For Each cel In .Cells(i, "P").Resize(numrows + 1)
                    cel.Offset(, 1) = cel & "00"
                Next
            End If
        Next i
    End With

[ramesh kola]

xld

Please help me for new output requirement.

[ramesh kola]

With sh
        .Range("Q1").EntireColumn.Insert
        .Range("Q1") = "Type"
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = lastrow To 2 Step -1
            codes = Split(.Cells(i, "P"), "/")
            numrows = UBound(codes) - LBound(codes)
            If numrows > 0 Then
                .Rows(i + 1).Resize(numrows).Insert
                .Rows(i).Copy .Cells(i, "A").Resize(numrows + 1)
                .Cells(i, "P").Resize(numrows + 1) = Application.Transpose(codes)
                For Each cel In .Cells(i, "P").Resize(numrows + 1)
                    cel.Offset(, 1) = cel & "00"
                Next
            End If
        Next i
    End With

It's worked Mack but my requirement is change below I'm attaching new output sheet attached marking xld.

Now you are column Q you are append code with 00 but my new requiremnt is if P column is 20 Q is column 20 open
2B - 2B closed

[ramesh kola]

Done My code is worked

Thanks all