Split Cells into rows but with two columns

[Sully1440]

Hi All,
I am trying to split cells into rows but I have two columns to review. When I try to split the cells, they don't line up. I found some code to get me going but unfortunately I'm struggling getting it working.

Objective: Take cells from Column C and Column E and split the cells into rows. For example, the data could be "A04, A05" (Column C) and "A07" (Column E) . I want a new inserted row(s) so that the table copies the row down (Col A, Col B, etc) except Col C would be A04 and A05 with the corresponding A07 from Col E.

I'm attaching the sample file with dummy data. Here is the code:


Sub Splt()
Dim LR As Long, i As Long
Dim X As Variant
Application.ScreenUpdating = False
LR = Range("C" & Rows.Count).End(xlUp).Row

Columns("C").Insert
For i = LR To 1 Step -1
With Range("D" & i)
If InStr(.Value, ",") = 0 Then
.Offset(, 0).Value = .Value
Else
X = Split(.Value, ",")
.Offset(1).Resize(UBound(X)).EntireRow.Insert
.Offset(, 0).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End If
End With
Next i
Columns("C").Delete

Columns("E").Insert
For i = LR To 1 Step -1
With Range("F" & i)
If InStr(.Value, ",") = 0 Then
.Offset(, 0).Value = .Value
Else
X = Split(.Value, ",")
.Offset(1).Resize(UBound(X)).EntireRow.Insert
.Offset(, 0).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End If
End With
Next i
Columns("E").Delete


'Columns("B").Delete
'LR = Range("A" & Rows.Count).End(xlUp).Row
'With Range("B1:C" & LR)
' On Error Resume Next
' .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
' On Error GoTo 0
' .Value = .Value
'End With
Application.ScreenUpdating = True
End Sub

[Sully1440]

I added another file with a table (starting at P1) to show exactly the desired result from the table starting in A1

[mikerickson]

I think this will do what you want.

Sub test()
Dim SourceRange As Range, DestinationRange As Range
Dim i As Long, maxRow As Long, cellParts As Variant, splitSize As Long
Set SourceRange = Range("A1")
Set DestinationRange = Range("k1")

DestinationRange.EntireColumn.ClearContents
With SourceRange
With Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)).Resize(, 6)
Set SourceRange = .Cells
Set DestinationRange = DestinationRange.Resize(.Rows.Count, 6)
End With
End With

With DestinationRange
.EntireColumn.ClearContents
.Value = SourceRange.Value
maxRow = .Rows.Count
End With
i = 3
Do
With DestinationRange.Rows(i)

cellParts = Split(CStr(.Cells(1, 3).Value), ", ")
splitSize = UBound(cellParts)
If splitSize < 1 Then
cellParts = Split(CStr(.Cells(1, 5).Value), ", ")
splitSize = UBound(cellParts)
If splitSize < 1 Then
i = i + 1
Else
.Offset(1, 0).Resize(splitSize, .Columns.Count).Insert
.Resize(splitSize + 1, .Columns.Count).FillDown
.Cells(1, 5).Resize(splitSize + 1, 1).Value = Application.Transpose(cellParts)
maxRow = maxRow + splitSize
End If
Else
.Offset(1, 0).Resize(splitSize, .Columns.Count).Insert
.Resize(splitSize + 1, .Columns.Count).FillDown
.Cells(1, 3).Resize(splitSize + 1, 1).Value = Application.Transpose(cellParts)
maxRow = maxRow + splitSize
End If
End With
Loop Until maxRow < i
End Sub

[p45cal]

or try this directly on (a copy of) your PERT CHART sheet:
Sub Splt()
'Macro2
Dim LR As Long, i As Long
Dim X As Variant
Application.ScreenUpdating = False
LR = Range("C" & Rows.Count).End(xlUp).Row

For i = LR To 1 Step -1
With Range("C" & i)
If InStr(.Value, ",") > 0 Then
X = Split(.Value, ",")
With Range("A" & i).Resize(, 6)
.Copy
.Offset(1).Resize(UBound(X)).Insert Shift:=xlDown
.Offset(1).Resize(UBound(X)).Value = .Value
End With
.Offset(, 0).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End If
End With
Next i

LR = Range("C" & Rows.Count).End(xlUp).Row

For i = LR To 1 Step -1
With Range("E" & i)
If InStr(.Value, ",") > 0 Then
X = Split(.Value, ",")
With Range("A" & i).Resize(, 6)
.Copy
.Offset(1).Resize(UBound(X)).Insert Shift:=xlDown
.Offset(1).Resize(UBound(X)).Value = .Value
End With
.Offset(, 0).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End If
End With
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
It inserts rows in columns A to F.

[Sully1440]

Hi p45cal,

I think I got most of it working with the exception of one small problem. When an activity code has 2 predecessors, it works ok, but when it has 3 predecessors, it doesn't repeat or copy down...the cells in column A and B are blank. For example, when I click the macro "SPLT", A18 and A22 doesn't fill in or repeat the activity code and description. The predecessors are transposed down just like I want it to but Column A and Column values do not fill in.

Here's my simple code and attached file (the macro button is on the first tab and I want it to look like the last tab)

Sub Splt()
Dim LR As Long, i As Long
Dim X As Variant
Dim Y As Variant
Dim Z As Variant
'Application.ScreenUpdating = False
LR = Range("C" & Rows.Count).End(xlUp).Row
For i = LR To 1 Step -1
With Range("C" & i)
If InStr(.Value, ",") = 0 Then
.Offset(, 0).Value = .Value
Else
X = Split(.Value, ",")
.Offset(1).Resize(UBound(X)).EntireRow.Insert
.Offset(, 0).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
With Range("A" & i)
Y = Cells(i, 1).Value
.Offset(1, 0).Value = .Value
End With
With Range("B" & i)
Z = Cells(i, 1).Value
.Offset(1, 0).Value = .Value
End With
End If
End With

Next i
'Application.ScreenUpdating = True
End Sub

[p45cal]

Why ask for help then completely ignore it?

[Sully1440]

Sorry. I didn't ignore it.
i should've said that I tried your suggested code but it was erroring.
Then, after further review, I didn't need to transpose column C.
My requirements changed. I went back to my code and realized I only needed half of it.
As a result, I thought it was best to re-explain what I was trying to do which is replicate or repeat columns A and B.

can you help me please?

[Sully1440]

I meant Column E. I didn't need to transpose Column E. I only wanted Column C to transpose.
My problem is with Column A and B not filling in.

[p45cal]

See attached.
I went back to my code and realized I only needed half of it.Then remove half my code (although it doesn't make any difference to the result on your sample sheet from my original code):

Sub SpltB()
Dim LR As Long, i As Long
Dim X As Variant
Application.ScreenUpdating = False
LR = Range("C" & Rows.Count).End(xlUp).Row

For i = LR To 1 Step -1
With Range("C" & i)
If InStr(.Value, ",") > 0 Then
X = Split(.Value, ",")
With Range("A" & i).Resize(, 6)
.Copy
.Offset(1).Resize(UBound(X)).Insert Shift:=xlDown
.Offset(1).Resize(UBound(X)).Value = .Value
End With
.Offset(, 0).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
End If
End With
Next i

'LR = Range("C" & Rows.Count).End(xlUp).Row
'
'For i = LR To 1 Step -1
' With Range("E" & i)
' If InStr(.Value, ",") > 0 Then
' X = Split(.Value, ",")
' With Range("A" & i).Resize(, 6)
' .Copy
' .Offset(1).Resize(UBound(X)).Insert Shift:=xlDown
' .Offset(1).Resize(UBound(X)).Value = .Value
' End With
' .Offset(, 0).Resize(UBound(X) - LBound(X) + 1).Value = Application.Transpose(X)
' End If
' End With
'Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

[Sully1440]

I am such a boob. I just noticed that you replied with a second message with my code. I am sorry!!!

I'm looking at it now.

[Sully1440]

AWESOME.....It works perfectly. THANK YOU, THANK YOU, THANK YOU :)
I like the SpltB version.

:)