VBA

Question

长期 reader 和 Whosebug 的仰慕者。

基本上我试图遍历一系列 Excel 文件以复制一系列数据并将其粘贴到单个 Excel workbook/sheet.

单元格范围位置 (C3:D8, D3:E8) 并不总是一致的，但 table 尺寸为：29 R x 2 C。另外，文件只有 1 sheet，除指定的 table 维度外，其他单元格中没有数据值。

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

我需要它

查找文件中的数据维度(table)
复制table
粘贴到目的地（在前一个 table 下方）
循环到下一个文件
重复步骤 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

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

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

您需要修改工作簿名称的存储范围。需要把列号传进去，这样才能算出最后一行。您还可以修改将数据粘贴回工作簿的列。

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 = 真

结束子

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

VBA - Copying and Pasting from Multiple Excel files to Single Excel File

excel

copy

file

paste