# Help copying data and transpose from one sheet to new sheet

#### TxRob81

##### New Member
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.
 Data1 Data2 Data3 Data4 Data5 A2 D2 E2 CK1 CK2 A2 D2 E2 CL1 CL2 A2 D2 E2 CM1 CM2 A2 D2 E2 CN1 CN2 A2 D2 E2 CO1 CO2 A2 D2 E2 CP1 CP2 A2 D2 E2 CQ1 CQ2 A2 D2 E2 CR1 CR2 A2 D2 E2 CS1 CS2 A2 D2 E2 CT1 CT2 A2 D2 E2 CU1 CU2 A2 D2 E2 CV1 CV2 A2 D2 E2 CW1 CW2 A2 D2 E2 CX1 CX2 A2 D2 E2 CY1 CY2 A2 D2 E2 CZ1 CZ2 A2 D2 E2 DA1 DA1 A2 D2 E2 DB1 DB2 A2 D2 E2 DC1 DC2 A2 D2 E2 DD1 DD2

<tbody>
</tbody>

### Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},\$Z\$1:\$Z\$99,\$Y\$1:\$Y\$99),2,False) to lookup Y values to left of Z values.

#### Leith Ross

##### Well-known Member
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.

Code:
``````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

##### MrExcel MVP, Moderator
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.

Rich (BB code):
``````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``````

Replies
3
Views
83
Replies
3
Views
176
Replies
5
Views
110
Replies
2
Views
149
Replies
2
Views
151

1,127,073
Messages
5,622,527
Members
415,905
Latest member
8765309

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

### Which adblocker are you using?

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

### Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back