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 

确保您复制两个函数，它们用于创建表的维度，然后复制表。

您将需要修改工作表名称变量。如果您有任何问题，请告诉我。

您需要修改存储工作簿名称的范围。您需要输入列号，以便计算最后一行。您还可以修改将数据粘贴回工作簿的列。