split cell data into row

[papil]

Hi,

I need help with this query-I want to split the data present in one of the column to multiple rows keeping all other info same.I am using excel 2013.Vlaues in column D will be multiple and separated by spaces.for eg-

Input Columns value-
A B C D E F
1 Hi Yes aaa bbb Bye 99

Ouput-
A B C D E F
1 Hi Yes aaa Bye 99
1 Hi Yes bbb Bye 99

thanks in advance.

 

[papil]

It works but if i dont have any value in a cell it copies the column header value down.

 

[Rick Rothstein]

It works but if i dont have any value in a cell it copies the column header value down.

I am going to assume you are referring to the code contained in the link I posted in Message #6. You should really include some kind of indication who you are responding to when there are multiple respondents so the right person knows to answer you. The best way to do that is to click the "Reply With Quote" hyperlink instead of the "Reply" hyperlink and then delete the text that is not relevant to your reply.

Here is the code from my mini-blog modified to ignore blank cells wherever they may occur...

[table="width: 500"]
[tr]
	[td]Sub RedistributeData()
  Dim X As Long, LastRow As Long, A As Range, Table As Range, Data() As String
  Const Delimiter As String = " "
  Const DelimitedColumn As String = "D"
  Const TableColumns As String = "A:CF"
  Const StartRow As Long = 2
  Application.ScreenUpdating = False
  LastRow = Columns(TableColumns).Find(What:="*", SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
  Intersect(Columns(TableColumns), Rows(StartRow & ":" & LastRow)).SpecialCells(xlBlanks).Value = "#N/A"
  For X = LastRow To StartRow Step -1
    If Not IsError(Cells(X, DelimitedColumn)) Then
      Data = Split(Cells(X, DelimitedColumn), Delimiter)
      If UBound(Data) > 0 Then
        Intersect(Rows(X + 1), Columns(TableColumns)).Resize(UBound(Data)).Insert xlShiftDown
      End If
      If Len(Cells(X, DelimitedColumn)) Then
        Cells(X, DelimitedColumn).Resize(UBound(Data) + 1) = WorksheetFunction.Transpose(Data)
      End If
    End If
  Next
  LastRow = Cells(Rows.Count, DelimitedColumn).End(xlUp).Row
  On Error Resume Next
  Set Table = Intersect(Columns(TableColumns), Rows(StartRow).Resize(LastRow - StartRow + 1))
  If Err.Number = 0 Then
    Table.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    Columns(DelimitedColumn).SpecialCells(xlFormulas).Clear
    Table.Value = Table.Value
  End If
  On Error GoTo 0
  Columns(TableColumns).SpecialCells(xlConstants, xlErrors).ClearContents
  Application.ScreenUpdating = True
End Sub[/td]
[/tr]
[/table]

 

[papil]

Sorry for the confusion. I was referring to the code you provided.

The new code you provided works perfect !! thank you.

I am going to assume you are referring to the code contained in the link I posted in Message #6. You should really include some kind of indication who you are responding to when there are multiple respondents so the right person knows to answer you. The best way to do that is to click the "Reply With Quote" hyperlink instead of the "Reply" hyperlink and then delete the text that is not relevant to your reply.

Here is the code from my mini-blog modified to ignore blank cells wherever they may occur...

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub RedistributeData()
  Dim X As Long, LastRow As Long, A As Range, Table As Range, Data() As String
  Const Delimiter As String = " "
  Const DelimitedColumn As String = "D"
  Const TableColumns As String = "A:CF"
  Const StartRow As Long = 2
  Application.ScreenUpdating = False
  LastRow = Columns(TableColumns).Find(What:="*", SearchOrder:=xlRows, _
            SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
  Intersect(Columns(TableColumns), Rows(StartRow & ":" & LastRow)).SpecialCells(xlBlanks).Value = "#N/A"
  For X = LastRow To StartRow Step -1
    If Not IsError(Cells(X, DelimitedColumn)) Then
      Data = Split(Cells(X, DelimitedColumn), Delimiter)
      If UBound(Data) > 0 Then
        Intersect(Rows(X + 1), Columns(TableColumns)).Resize(UBound(Data)).Insert xlShiftDown
      End If
      If Len(Cells(X, DelimitedColumn)) Then
        Cells(X, DelimitedColumn).Resize(UBound(Data) + 1) = WorksheetFunction.Transpose(Data)
      End If
    End If
  Next
  LastRow = Cells(Rows.Count, DelimitedColumn).End(xlUp).Row
  On Error Resume Next
  Set Table = Intersect(Columns(TableColumns), Rows(StartRow).Resize(LastRow - StartRow + 1))
  If Err.Number = 0 Then
    Table.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
    Columns(DelimitedColumn).SpecialCells(xlFormulas).Clear
    Table.Value = Table.Value
  End If
  On Error GoTo 0
  Columns(TableColumns).SpecialCells(xlConstants, xlErrors).ClearContents
  Application.ScreenUpdating = True
End Sub[/TD]
[/TR]
</tbody>[/TABLE]