Splitting data from one column into other 4 columns in excel

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

Attachment 20353

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 ..

Code:

---

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

---

@xld,

I think OP want result in other sheet.
Thanks.

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

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

Code:

---

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

---

Thanks Tom!!

You are just Awesome.. Thanks for your help

Quote:

---

Originally Posted by ramesh kola

Thanks Tom!!

You are just Awesome.. Thanks for your help

---

Tom is Bob!

Quote:

---

Originally Posted by ramesh kola

Thanks Tom!!

You are just Awesome.. Thanks for your help

---

No, no.

All merits goes to Bob.

Quote:

---

Originally Posted by xld

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..!!

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

Quote:

---

Originally Posted by mdmackillop

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

---

Hi

required Output sheet attached

Code:

---

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

---

xld

Please help me for new output requirement.

Quote:

---

Originally Posted by mdmackillop

Code:

---

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

Done My code is worked

Thanks all