Excel VBA - 如何复制和转置粘贴另一张纸

Question

I try to copy data from Workbooks with Sheets("daily shift report") to another Workbooks Sheets ("Sheet1") by transpose according to the code below.

Sub copyDatafrommultipleworkbookintomaster()
Dim FolderPath As String, Filepath As String, Filename As String, Erow As Range
FolderPath = "C:\Users\YIT\Documents\test\April57\"
Filepath = FolderPath & "*.xls*"
Filename = Dir(Filepath)

Do While Filename <> ""
Workbooks.Open (FolderPath & Filename)
ActiveWorkbook.Sheets("daily shift report").Range("B71:G77").Copy
Application.DisplayAlerts = False
ActiveWorkbook.Close


Worksheets("Sheet1").Range("A1").PasteSpecial Transpose:=True
Filename = Dir

Loop
End Sub

But found Run time error '1004' Application-defined or object-defined error.I guess error in line 14. Worksheets("Sheet1").Range("A1").PasteSpecial Transpose:=True Could you please suggest a solution to this problem?.

Answer 1

Try the next code, please. It will Paste, from each existing.xls workbook, in the next empty column of "Sheet1":

Sub copyDatafrommultipleworkbookintomaster()
 Dim FolderPath As String, Filepath As String, Filename As String
 Dim wb As Workbook, ws As Worksheet, Col As Long
 
 Col = 1
 Set ws = ActiveWorkbook.Sheets("Sheet1")
 FolderPath = "C:\Users\YIT\Documents\test\April57\"
 Filename = Dir(FolderPath & "*.xls*")

 Do While Filename <> ""
    Set wb = Workbooks.Open(FolderPath & Filename)
    wb.Sheets("daily shift report").Range("B71:G77").Copy
    ws.cells(1, Col).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    Col = Col + 7 'increment the next col where to paste
    wb.Close False
    
    Filename = Dir
 Loop
End Sub

Answer 2

Please see if either of following two set of codes is useful to you.

1. Mention your Source File Path & File name directly as string

Sub GetData()

Dim customerFilename As String
Dim customerWorkbook As Workbook
Dim targetSheet As Worksheet, sourceSheet As Worksheet

    'targetSheet is Activeworkbook wherein you would want to fetch the data
    Set targetSheet = ActiveWorkbook.Worksheets("Sheet1")
    
    'Mention Source-file path & file name between double quotes below
    customerFilename = "C:\Users\YIT\Documents\test\April57\Your_File_Name_Here.xls"
    
    Set customerWorkbook = Application.Workbooks.Open(customerFilename)
    
    Set sourceSheet = customerWorkbook.Worksheets("daily shift report")
    
    sourceSheet.Range("B71:G77").Copy
    'select in which cell you want to paste data
    targetSheet.Range("A1").PasteSpecial Transpose:=True
    customerWorkbook.Close

End Sub

2. In this code you will be prompted to select Source File (.xls or.xlsx or.csv), no need to manually write Source Filepath & Filename.

Sub GetData2()

Dim filter As String, caption As String
Dim customerFilename As String
Dim customerWorkbook As Workbook
Dim targetSheet As Worksheet, sourceSheet As Worksheet

    'targetSheet is Activeworkbook wherein you would want to fetch the data
    Set targetSheet = ActiveWorkbook.Worksheets("Sheet1")
    
    'Prompt to get the customerWorkbook i.e. Source Workbook
    filter = "Excel and CSV Files (*.xls;*.xlsx;*.csv),*.xls;*.xlsx;*.csv"
    caption = "Please Select an input file "
    customerFilename = Application.GetOpenFilename(filter, , caption)
    
    Set customerWorkbook = Application.Workbooks.Open(customerFilename)
    Set sourceSheet = customerWorkbook.Worksheets("daily shift report")
    
    sourceSheet.Range("B71:G77").Copy
    'select in which cell you want to paste data
    targetSheet.Range("A1").PasteSpecial Transpose:=True 
    customerWorkbook.Close

End Sub

Hope these codes are useful to you. Regards.