Question

StackOverflow的长期读者和崇拜者。

基本上我试图循环浏览一系列Excel文件来复制一系列数据并将其粘贴到一个Excel工作簿/工作表上。

单元格范围位置（C3：D8，D3：E8）并不总是一致，但表格尺寸为：29 R x 2 C.此外，文件只有1张，除了指定的表格尺寸外，其他单元格中没有数据值。

以当前形式执行代码，但不将任何内容粘贴到目标Excel文件中。

我需要它

在文件（表格）中查找数据维度
复制表格
粘贴到目的地（在上一张桌子下面）
循环到下一个文件
重复步骤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

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

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

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

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

Application.EnableEvents = True

结束子

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

2 个答案: