PDA

View Full Version : [SOLVED] Splitting data from one column into other 4 columns in excel



ramesh kola
09-14-2017, 02:21 PM
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

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

Bob Phillips
09-14-2017, 02:46 PM
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
09-15-2017, 01:33 AM
@xld,

I think OP want result in other sheet.
Thanks.

ramesh kola
09-15-2017, 02:24 AM
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
09-15-2017, 05:22 AM
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
09-15-2017, 07:53 AM
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
09-15-2017, 08:05 AM
Thanks Tom!!

You are just Awesome.. Thanks for your help

Bob Phillips
09-15-2017, 09:45 AM
Thanks Tom!!

You are just Awesome.. Thanks for your help

Tom is Bob!

Tom Jones
09-16-2017, 02:18 AM
Thanks Tom!!

You are just Awesome.. Thanks for your help

No, no.

All merits goes to Bob.

ramesh kola
09-27-2017, 11:49 AM
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
09-27-2017, 12:36 PM
Can you post an Output sheet showing desired result. I'm not clear what goes into Type

ramesh kola
09-27-2017, 12:46 PM
Can you post an Output sheet showing desired result. I'm not clear what goes into Type

Hi

required Output sheet attached

mdmackillop
09-27-2017, 01:00 PM
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
09-28-2017, 05:49 AM
xld

Please help me for new output requirement.

ramesh kola
09-28-2017, 05:57 AM
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
09-28-2017, 06:10 AM
Done My code is worked

Thanks all