VBA - 从多个Excel文件复制粘贴到单个Excel文件

Question

我长期以来一直是StackOverflow的忠实读者和钦佩者。

基本上，我正在尝试循环遍历一系列Excel文件，将一定范围的数据复制并粘贴到单个Excel工作簿/工作表中。

单元格范围位置（C3：D8，D3：E8）不总是一致的，但表格维度为：29R x 2C。此外，这些文件只有1个工作表，在指定的表格维度之外没有其他单元格数据值。

目前的代码正在执行，但没有将任何内容粘贴到其目标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

- Andrew Karl

---

你的代码看起来很好，你尝试过在断点模式下查看它吗？你只需要调整初始数据范围的部分，但这并不是什么难事（因为你已经知道了 End() 函数）。但我不明白为什么目标工作表中没有任何数据... - R3uK

如果在 rDest.Resize(5, 1).Value = wbSource.Sheets(1).Range("C7:D33").Value 行之前尝试使用 wbSource.Sheets(1).Range("C7:D33").Select，它将突出显示源数据。使用 F8 逐步执行代码并检查源范围是否正确。接下来尝试使用 rDest.Resize(5, 1).Select 检查目标范围。一旦这些都正确，您可以在完成调试后删除这两行。 - tonester640

谢谢，有趣的是当使用F8滚动代码时，它到达行Set wbDest = Workbooks.Open(sDestPath & "" & "Book2.xlsm")时，Excel文件Book2会打开，但代码就停止了？ - Andrew Karl

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

请确保将这两个函数一起复制，它们用于创建表格的维度，然后复制表格。

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

您需要修改工作簿名称存储的范围。您需要传递列号进去，以便可以计算出最后一行。您还可以修改数据被粘贴回工作簿的列。

- luke_t

---

谢谢您的回复Iturner，只有一个问题，我正在尝试复制并粘贴到最终文件中的数据维度位于单独的Excel文件中，是否可以修改WsSrc以便它转到另一个文件并从中提取数据？ - Andrew Karl

成功了！干杯！非常感谢，希望你不介意我再次打扰；现在我要尝试一下是否可以使用特殊粘贴数据范围，并且我认为这段代码是一个很好的开端。再次感谢并祝你有一个愉快的一周 :) - Andrew Karl

嗨Iturner，我需要跟进一下宏，它的效果非常好，除了一个问题，那就是数据的问题。代码复制并粘贴了一个数据表范围，但只有1列而不是2列。我认为这是因为前几个单元格被合并了，所以当代码复制范围时，它只取了第一列范围，忽略了另一列。 - Andrew Karl

嗯...好吧，我首先建议尝试在不使用合并单元格的情况下对工作簿进行格式化。如果这不可行，请告诉我。 - luke_t

嗯...这不是一个选项，因为我需要代码来自动化这个过程，而不必单独进入文件。然而，我尝试取消合并单元格，但它仍然只复制了1列而不是2列。谢谢 :) - Andrew Karl

Answer 2

通过这段代码的帮助，您可以将所有工作簿和工作表数据复制到一个工作簿中。

Sub copydata()

Dim fso As Scripting.FileSystemObject
Dim fill As Scripting.File
Dim oldfolder As String
Dim newfolder As String
Dim subfolder As Folder
Dim myfolder As Folder
Dim fd As FileDialog
Dim loopcount As Integer
Dim wb
Dim wb2 As Workbook
Dim rr As Range

Set fso = New Scripting.FileSystemObject

Set wb = ThisWorkbook

Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Please Select Folder to copy"
fd.ButtonName = "Go!"
fd.Show

oldfolder = fd.SelectedItems(1)

Set myfolder = fso.GetFolder(oldfolder)

'Application.ScreenUpdating = False

Application.EnableEvents = False
 

For Each subfolder In myfolder.SubFolders

    For Each fill In subfolder.Files
            If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Then
            'fill.Range("A1:Z100").Copy
            Set wb2 = Application.Workbooks.Open(fill,0 , True)
            wb2.Activate
            For loopcount = 1 To wb2.Worksheets.Count
            wb2.Activate
            Worksheets(loopcount).Activate
            Range("A1:Z300").Copy          'Replace your range
            wb.Activate
            Sheet1.Activate
            Set rr = Range("A:A").Find("", Range("A1"))
            rr.Select
            ActiveSheet.Paste
            ActiveCell.Offset(1, 0).Select
            Next loopcount
            wb2.Close False
            End If
            
        Application.CutCopyMode = False
        
        Debug.Print fill.Name
    
    Next fill
    
Next subfolder
        MsgBox "Done"

    For Each fill In myfolder.Files
        Application.DisplayAlerts = False
    
         If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Or fill Like "*.xlsb" Then
            'fill.Range("A1:Z100").Copy
            Set wb2 = Application.Workbooks.Open(fill, 0, True)
            wb2.Activate
            
            For loopcount = 1 To wb2.Worksheets.Count
        
            wb2.Activate
            Worksheets(loopcount).Activate
            
            Range("A:Z").EntireColumn.Hidden = False
            
            Range("A1:Z1").AutoFilter
            Range("A1:Z300").Copy
            wb.Activate
            
            Sheet1.Activate
            Set rr = Range("A:A").Find("", Range("A1"))
            rr.Select
            ActiveSheet.Paste
            ActiveCell.Offset(1, 0).Select
            Next loopcount
            wb2.Close False
            End If
            
        Application.CutCopyMode = False
        
        Debug.Print fill.Name
        
    Next fill

应用程序.启用事件 = True

结束子程序

- mithun