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.