打开文件夹中的所有 Excel 工作簿并复制和粘贴

Question

我想逐一打开文件夹中的所有 Excel 工作簿并将单元格 B1 复制到活动工作簿中。
引用对吗？

Sub CopyPaste
    Const strVerzeichnis As String = "C:\Users\amke\Desktop"
    Dim StrDatei As String
    Const StrTyp As String = "*.xls"
    Dim Dateiname As String
    
    ThisWorkbook.Activate
    Dateiname = Dir(strVerzeichnis & StrTyp)
    Application.ScreenUpdating = False

    Do While Dateiname <> ""
        Workbooks.Open Filename:=strVerzeichnis & Dateiname

        Workbooks(Filename).Worksheets("sheet1").Cells("B1").Copy _
          Workbooks(ThisWorkbook).Worksheets("sheet1").Range("B1")
    Loop

    Application.ScreenUpdating = True
End Sub

Answer 1

一些修复：

Sub CopyPaste
    Const strVerzeichnis As String = "C:\Users\amke\Desktop\" 'Add trailing \
    Dim StrDatei As String
    Const StrTyp As String = "*.xls"
    Dim Dateiname As String, rngPaste As Range
    
    Set rngPaste = ThisWorkbook.Worksheets("sheet1").Range("B1")
    
    Application.ScreenUpdating = False
    
    Dateiname = Dir(strVerzeichnis & StrTyp)
    Do While Dateiname <> ""
        With Workbooks.Open(Filename:=strVerzeichnis & Dateiname)
            .Worksheets("sheet1").Cells("B1").Copy rngPaste
            Set rngPaste = rngPaste.offset(1, 0) 'next paste location
            .Close False                         'no save
        End with
        Dateiname = Dir() 'next file, if any 
    Loop
    Application.ScreenUpdating = True
End Sub