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

Question

I want to open all Excel workbooks in a folder, one-by-one and copy the cell B1 into the active workbook.
Are the references right?

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

A few fixes:

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