Help copying data and transpose from one sheet to new sheet

[TxRob81]

I have an issue. I told my wife I could write a script for this. Well its a bit out of my range. I thought it was easy but its not for me because I dont do this enough.

I have a spreadsheet and lets say I need to copy A2, D2, and E2 to another sheet 20 times but I also need to transpose the headings from columns CK1:DD1 into Column D, and then Transpose CK2:DD2 into column E. This is the data set (20).

Then I need to loop for each row this until the end of the list for lets say column D.

CK1:DD1 will always be the same 20 for each row that is copied.

Can anyone help? I know its a loop and transposing but not sure how to go about it.
Final result would look like this for each row from original sheet into final.
[TABLE="width: 500"]
<tbody>[TR]
[TD]Data1[/TD]
[TD]Data2[/TD]
[TD]Data3[/TD]
[TD]Data4[/TD]
[TD]Data5[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]CK1[/TD]
[TD]CK2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]CL1[/TD]
[TD]CL2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]CM1[/TD]
[TD]CM2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]CN1[/TD]
[TD]CN2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]CO1[/TD]
[TD]CO2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]CP1[/TD]
[TD]CP2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]CQ1[/TD]
[TD]CQ2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]CR1[/TD]
[TD]CR2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]CS1[/TD]
[TD]CS2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]CT1[/TD]
[TD]CT2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]CU1[/TD]
[TD]CU2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]CV1[/TD]
[TD]CV2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]CW1[/TD]
[TD]CW2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]CX1[/TD]
[TD]CX2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]CY1[/TD]
[TD]CY2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]CZ1[/TD]
[TD]CZ2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]DA1[/TD]
[TD]DA1[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]DB1[/TD]
[TD]DB2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]DC1[/TD]
[TD]DC2[/TD]
[/TR]
[TR]
[TD]A2[/TD]
[TD]D2[/TD]
[TD]E2[/TD]
[TD]DD1[/TD]
[TD]DD2[/TD]
[/TR]
</tbody>[/TABLE]

 

[Leith Ross]

Hello TxRob81,

Here is VBA macro do what you asked. Change the worksheet names in the macro code to match the names you are using. The variable name WksSrc refers to the Source Worksheet and WksDst refers to the Destination Worksheet.

Sub CopyAndTranspose()


    Dim Data    As Variant
    Dim RngDst  As Range
    Dim WksDst  As Worksheet
    Dim WksSrc  As Worksheet
    
        Set WksSrc = ThisWorkbook.Worksheets("Sheet1")
        Set WksDst = ThisWorkbook.Worksheets("Sheet2")
    
        Data = Array(WksSrc.Range("A2"), WksSrc.Range("D2"), WksSrc.Range("E2"))
        
        Set RngDst = WksDst.Range("A2:C2")
            RngDst.Resize(20, 3).Value = Data
            
        Data = Application.Transpose(WksSrc.Range("CK1:DD1"))
        WksDst.Range("D2").Resize(20, 1).Value = Data


        Data = Application.Transpose(WksSrc.Range("CK2:DD2"))
        WksDst.Range("E2").Resize(20, 1).Value = Data
            
End Sub

This code needs to be a VBA Module.

• Copy the macro above with Ctrl+C.
• Open the workbook and use Alt+F11 to open the VB Editor.
• Use ALT+I to display the Insert Menu.
• Press the M key to add a new Module.
• Paste the macro into the Module with Ctrl+V.
• Save the macro using Ctrl+S

You can then run the macro using the Macro Dialog. Press ALT and F8 together to display it. Click on CopyAndTranspose in the list then click RUN.

 

[Peter_SSs]

Welcome to the MrExcel board!

Then I need to loop for each row this until the end of the list for lets say column D.

This is my take on what you require. Check sheet names in the code & I have assumed that the 2nd sheet already exists but has no data (at least in columns A:E)

Test in a copy of your workbook.

Sub Testing()
  Dim ADE As Variant, CKDD As Variant
  Dim i As Long
  
  With Sheets("Sheet1")
    CKDD = Application.Transpose(.Range("CK1:DD2").Value)
    ADE = Application.Index(.Cells, Evaluate("row(2:" & .Range("D" & .Rows.Count).End(xlUp).Row & ")"), Array(1, 4, 5))
  End With
  With Sheets("Sheet2")
    For i = 1 To UBound(ADE)
      .Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(20, 3).Value = Application.Index(ADE, i, 0)
      .Range("D" & Rows.Count).End(xlUp).Offset(1).Resize(20, 2).Value = CKDD
    Next i
  End With
End Sub