Copy Row from work sheet an paste it to another workbook sheetwise

[arijitirf]

Hi!
My workbook contains data from A1 to E750. I want to copy data from A1:E1 and paste it to a new workbook Range A1:A5 in Sheet 1. Likewise copy A2:E2 and paste it to that new workbook A1:A5 in Sheet 2.

Help Required.

Thanks in advance.

 

[mumps]

Does the new workbook already exist or does the macro have to create it? If it already exists, what is its name including the extension? What is the sheet name where the data resides? You understand that what you want to do will create 750 sheets in the new workbook?

 

[arijitirf]

Yes, name of the target workbook is Letter.xlsx and name of the source workbook is Data.xlsx. Sheet name will be as Sheet1, Sheet2, Sheet3 ....

 

[mumps]

Do the 750 sheets already exist in the target workbook and if they do, are they named Sheet1 to Sheet750 sequentially?

 

[arijitirf]

Yes. My workbook contains 750 sheets and they are named Sheet1 to the end Sheet750 in ascending order.

 

[mumps]

Make sure that both workbooks are open. Place the macro below in a standard module in the Data.xlsx workbook and save it as a macro-enabled file so its extension changes to "xlsm". The macro assumes that the sheet containing data from A1 to E750 is named "Sheet1". Change this name in the code to suit your needs.

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim desWB As Workbook
    Set desWB = Workbooks("Letter.xlsx")
    Dim x As Long
    For x = 1 To 750
        Sheets("Sheet1").Range("A" & x & ":E" & x).Copy desWB.Sheets("Sheet" & x).Cells(1, 1)
    Next x
    Application.ScreenUpdating = True
End Sub

 

[arijitirf]

Thanks for your reply. But I need this data to be filled between A1:A5 (Transpose)

 

[mumps]

Try:

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim desWB As Workbook
    Set desWB = Workbooks("Letter.xlsx")
    Dim x As Long
    For x = 1 To 750
        Sheets("Sheet1").Range("A" & x & ":E" & x).Copy
        desWB.Sheets("Sheet" & x).Cells(1, 1).PasteSpecial Transpose:=True
    Next x
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[arijitirf]

Just awesome. Thank you so much.

 

[mumps]

You are very welcome.