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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.