Transpose discontiguous ranges from one row into two columns

[LuigiCortisone]

Hi, I have a master worksheet with code that creates a worksheet from every row. This works well but I now want to grab two cells from each row and use them to populate another column

Here is a simple screenshot of the master worksheet (dummy data) with the cells for the third column highlighted



And here is the desired result in the first worksheet after the code has run. Columns F and G for each row must populate the 3rd and 4th row of colC. Rows 1 & 2 are to be left blank



Here is the code I have already kindly provided by a forum moderator. This creates each new worksheet and transposes the first 4 columns. But now I just need to bring the other two cells across


Cheers, Luigi

Sub LuigiCortisone()
   Dim Cl As Range
   Dim Hdr As Variant
   
   With Sheets("Master")
      Hdr = .Range("A1:D1").Value2
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         If Not Evaluate("isref('" & Cl.Value & "'!A1)") Then
            Sheets.Add(, Sheets(Sheets.Count)).Name = Cl.Value
            With Sheets(Cl.Value)
               .Range("A1:A4").Value = Application.Transpose(Hdr)
               .Range("B1:B4").Value = Application.Transpose(Cl.Resize(, 4).Value)
            End With
         End If
      Next Cl
   End With
End Sub

 

[Trebor76]

Hi Luigi,

So using your code there's two ways I can think of (no doubt there's more):

Copy everything but then delete the extra row:

Option Explicit
Sub Macro1()
   
   Dim Cl As Range
   Dim Hdr As Variant
   
   Application.ScreenUpdating = False
   
   With Sheets("master")
      Hdr = .Range("A1:G1").Value2
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         If Not Evaluate("isref('" & Cl.Value & "'!A1)") Then
            Sheets.Add(, Sheets(Sheets.Count)).Name = Cl.Value
            With Sheets(Cl.Value)
               .Range("A1:A6").Value = Application.Transpose(Hdr)
               .Range("B1:B6").Value = Application.Transpose(Cl.Resize(, 6).Value)
               .Rows(5).Delete
            End With
         End If
      Next Cl
   End With
   
   Application.ScreenUpdating = True
   
End Sub

Or via a cell by cell basis which will become huge if you have many columns:

Option Explicit
Sub Macro2()

    Dim Cl As Range
    Dim Hdr As Range
    
    Application.ScreenUpdating = False

    With Sheets("master")
        Set Hdr = .Range("A1:D1,F1:G1")
        For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            If Not Evaluate("isref('" & Cl.Value & "'!A1)") Then
                Sheets.Add(, Sheets(Sheets.Count)).Name = Cl.Value
                Sheets(Cl.Value).Range("A1:A6") = Application.Transpose(Array(.Range("A1"), .Range("B1"), .Range("C1"), .Range("D1"), .Range("F1"), .Range("G1")))
                Sheets(Cl.Value).Range("B1:B6") = Application.Transpose(Array(.Range("A" & Cl.Row), .Range("B" & Cl.Row), .Range("C" & Cl.Row), .Range("D" & Cl.Row), .Range("F" & Cl.Row), .Range("G" & Cl.Row)))
            End If
        Next Cl
    End With
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[Fluff]

How about

Sub LuigiCortisone()
   Dim Cl As Range
   Dim Hdr As Variant
   
   With Sheets("Master")
      Hdr = .Range("A1:D1").Value2
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         If Not Evaluate("isref('" & Cl.Value & "'!A1)") Then
            Sheets.Add(, Sheets(Sheets.Count)).Name = Cl.Value
            With Sheets(Cl.Value)
               .Range("A1:A4").Value = Application.Transpose(Hdr)
               .Range("B1:B4").Value = Application.Transpose(Cl.Resize(, 4).Value)
               .Range("C3:C4").Value = Application.Transpose(Cl.Offset(, 5).Resize(, 2).Value)
            End With
         End If
      Next Cl
   End With
End Sub

 

[LuigiCortisone]

Hi Luigi,

So using your code there's two ways I can think of (no doubt there's more):

Copy everything but then delete the extra row:

Option Explicit
Sub Macro1()
  
   Dim Cl As Range
   Dim Hdr As Variant
  
   Application.ScreenUpdating = False
  
   With Sheets("master")
      Hdr = .Range("A1:G1").Value2
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         If Not Evaluate("isref('" & Cl.Value & "'!A1)") Then
            Sheets.Add(, Sheets(Sheets.Count)).Name = Cl.Value
            With Sheets(Cl.Value)
               .Range("A1:A6").Value = Application.Transpose(Hdr)
               .Range("B1:B6").Value = Application.Transpose(Cl.Resize(, 6).Value)
               .Rows(5).Delete
            End With
         End If
      Next Cl
   End With
  
   Application.ScreenUpdating = True
  
End Sub

Or via a cell by cell basis which will become huge if you have many columns:

Option Explicit
Sub Macro2()

    Dim Cl As Range
    Dim Hdr As Range
   
    Application.ScreenUpdating = False

    With Sheets("master")
        Set Hdr = .Range("A1:D1,F1:G1")
        For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            If Not Evaluate("isref('" & Cl.Value & "'!A1)") Then
                Sheets.Add(, Sheets(Sheets.Count)).Name = Cl.Value
                Sheets(Cl.Value).Range("A1:A6") = Application.Transpose(Array(.Range("A1"), .Range("B1"), .Range("C1"), .Range("D1"), .Range("F1"), .Range("G1")))
                Sheets(Cl.Value).Range("B1:B6") = Application.Transpose(Array(.Range("A" & Cl.Row), .Range("B" & Cl.Row), .Range("C" & Cl.Row), .Range("D" & Cl.Row), .Range("F" & Cl.Row), .Range("G" & Cl.Row)))
            End If
        Next Cl
    End With
   
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

Thanks Robert, but it doesn't populate colC. Fluff's code below does the trick

Cheers, L

 

[Fluff]

Glad we could help & thanks for the feedback.

 

[LuigiCortisone]

How about

Sub LuigiCortisone()
   Dim Cl As Range
   Dim Hdr As Variant
  
   With Sheets("Master")
      Hdr = .Range("A1:D1").Value2
      For Each Cl In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
         If Not Evaluate("isref('" & Cl.Value & "'!A1)") Then
            Sheets.Add(, Sheets(Sheets.Count)).Name = Cl.Value
            With Sheets(Cl.Value)
               .Range("A1:A4").Value = Application.Transpose(Hdr)
               .Range("B1:B4").Value = Application.Transpose(Cl.Resize(, 4).Value)
               .Range("C3:C4").Value = Application.Transpose(Cl.Offset(, 5).Resize(, 2).Value)
            End With
         End If
      Next Cl
   End With
End Sub

Thanks again Fluff. Perfetto!

Cheers, L