打开文件夹中的所有excel文件并复制特定文件

Question

我该怎么做

• 从启用宏的 Excel 文件所在的路径打开所有 Excel 文件
• 在所有 Excel 文件中选择名称为 b2b 的特定工作表
• 复制所有数据并粘贴到宏文件的Sheet1中
• 复制其他打开的 Excel 文件的每个 b2b 工作表的数据并将其粘贴到下一个空单元格
• 关闭除启用宏的文件以外的所有文件

仅适用于指定文件和位置的不完整宏。

Sub Step1OpenCopyPaste()
    Dim oCell As Range
    Dim rowCount As Integer
    ' open the source workbook and select the source sheet

    Workbooks.Open Filename:="\e\Rohit\Others\Rahul.xlsx"

    Sheets("B2B").Select

    ' copy the source range

    With Sheets("B2B")
        rowCount = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range(.Cells(1, 1), .Cells(rowCount, 7)).Select
        'Select.range(a7
    End With

    Selection.Copy

    ' select current workbook and paste the values starting at A1

    Windows("Macro.xlsx").Activate    
    Sheets("Sheet1").Select

    '------------------------------------------------
    With Sheets("Sheet1")
        Set oCell = .Cells(.Rows.Count, 1).End(xlUp)
    End With

    oCell.Select
    '------------------------------------------------

    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveWorkbook.Save


    Workbooks.Open Filename:="\\e\Rohit\Others\Rohit.xlsx"
    Sheets("B2B").Select

    ' copy the source range

    With Sheets("B2B")
        rowCount = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range(.Cells(1, 1), .Cells(rowCount, 7)).Select
    End With

    Selection.Copy

    ' select current workbook and paste the values starting at A1

    Windows("Macro.xlsx").Activate 
    Sheets("Sheet1").Select

    '------------------------------------------------
    With Sheets("Sheet1")
        Set oCell = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
    End With

    oCell.Select
    '------------------------------------------------

    ActiveSheet.Paste 
    Application.CutCopyMode = False  
    ActiveWorkbook.Save

    Dim wb As Workbook

    'Loop through each workbook
    For Each wb In Application.Workbooks
        'Prevent the workbook that contains the
        'code from being closed
        If wb.Name <> ThisWorkbook.Name Then        
            'Close the workbook and don't save changes
            wb.Close SaveChanges:=False
        End If
    Next wb
End Sub

Answer 1

它应该看起来像这样：

Dim Filename As String
Dim lLastRow As Long
Dim wbDst As Workbook, wbSrce As Workbook
Dim wsDst As Worksheet

Set wsDst = ThisWorkbook.Worksheets("Sheet1")
Filename = Dir("C:\Users\You\Documents\Test\*.xlsx")
    
    Do While Filename <> ""
        Set wbSrce = Workbooks.Open(Filename)
        lLastRow = wsDst.UsedRange.Rows.Count + 1
            wbSrce.Sheets("B2B").UsedRange.Copy wsDst.Range("A" & lLastRow)
            wbSrce.Close savechanges:=False
        Filename = Dir
    Loop