VBA - 從多個Excel文件複製並粘貼到單個Excel文件

Question

長時間閱讀器和StackOverflow的崇拜者。

基本上我試圖通過一系列Excel文件來複制一系列數據並將其粘貼到一個Excel工作簿/工作表上。

單元格區域位置（C3：D8，D3：E8）並不總是一致的，但表格尺寸爲：29 R x 2 C.此外，這些文件只有一個表格，並且除了指定的表格尺寸，其他單元格中沒有數據值。

在其當前形式的代碼正在執行，但沒有粘貼任何東西到其目標Excel文件。

我需要它

1. 通過到下一個文件
查找文件（表）的數據維度
2. 複製表
3. 粘貼到目的地（以前見下表）
4. 循環
5. 重複步驟1-4

該代碼是從： Excel VBA: automating copying ranges from different workbooks into one final destination sheet?

非常感謝任何幫助，我真的很感激它，並請感覺告訴我，如果我的問題含糊不清，請指定任何內容。

Sub SourcetoDest() 

    Dim wbDest As Workbook 
    Dim wbSource As Workbook 
    Dim sDestPath As String 
    Dim sSourcePath As String 
    Dim shDest As Worksheet 
    Dim rDest As Range 
    Dim vaFiles As Variant 
    Dim i As Long 

    'array of folder names under sDestPath 

    'array of file names under vaFiles 
    vaFiles = Array("Book1.xls") 

    sDestPath = "C:\Users" 
    sSourcePath = "C:\Users" 


    Set wbDest = Workbooks.Open(sDestPath & "\" & "Book2.xlsm") 
    Set shDest = wbDest.Sheets(1) 

    'loop through the files 
    For i = LBound(vaFiles) To UBound(vaFiles) 
     'open the source 
     Set wbSource = Workbooks.Open(sSourcePath & "\" & vaFiles(i)) 

     'find the next cell in col C 
     Set rDest = shDest.Cells(shDest.Rows.Count, 3).End(xlUp).Offset(1, 0) 
     'write the values from source into destination 
     rDest.Resize(5, 1).Value = wbSource.Sheets(1).Range("C7:D33").Value 


     wbSource.Close False 
    Next i 

End Sub 

Answer 1

下面的內容應該可以達到你想要的效果。

Option Explicit 
Sub copy_rng() 
    Dim wb As Workbook, wbDest As Workbook, ws As Worksheet, wsDest As Worksheet, wsSrc As Worksheet 
    Dim wbNames() As Variant 
    Dim destFirstCell As Range 
    Dim destColStart As Integer, destRowStart As Long, i As Byte 
    Dim destPath As String 

    Set wb = ThisWorkbook 
    Set ws = wb.Sheets("Sheet1") ' Amend to your sheet name 
    Set wsSrc = wb.Sheets("Sheet2") ' Amend to sheet name with table data 
    wbNames = ws.Range("A2:A" & lrow(1, ws)) ' Pass col number into lrow function 
    destPath = "C:\Users\" 

    Application.ScreenUpdating = False 
    For i = 1 To UBound(wbNames, 1) 
     Set wbDest = Workbooks.Open(destPath & wbNames(i, 1)) 
     Set wsDest = wbDest.Worksheets(1) 
     With wsDest 
      Set destFirstCell = .Cells.Find(What:="*") 
      destColStart = destFirstCell.Column 
      destRowStart = destFirstCell.Row 
      .Range(Cells(destRowStart, destColStart), _ 
       Cells(lrow(destColStart, wsDest), icol(destRowStart, wsDest))).Copy 
     End With 
     wsSrc.Cells(lrow(1, wsSrc) + 1, 1).PasteSpecial Paste:=xlPasteAll 
     wbDest.Close False 
    Next i 
    Application.ScreenUpdating = True 

End Sub 

Function lrow(ByVal col_num As Integer, sheet_name As Worksheet) As Long 
    lrow = sheet_name.Cells(Rows.Count, col_num).End(xlUp).Row 
End Function 

Function icol(ByVal row_num As Long, sheet_name As Worksheet) As Integer 
    icol = sheet_name.Cells(row_num, Columns.Count).End(xlToLeft).Column 
End Function 

確保您複製兩個函數，它們用於創建表的維度，然後複製表。

您將需要修改工作表名稱變量。如果您有任何問題，請告訴我。

您需要修改存儲工作簿名稱的範圍。您需要輸入列號，以便計算最後一行。您還可以修改將數據粘貼回工作簿的列。