Daten aus anderen Excel-Sheets kopieren

[Flotter Feger]

Hallo,

wieso per PN ? gehört doch zum Thread ?  

versuch es mal so ...

Code:

Option Explicit

Sub Komplett()
Dim i As Byte
Dim Ordner1 As String
Dim Ordner2 As String
Dim Datei As Variant
Dim WB As Workbook
Dim UE As Worksheet

Ordner1 = "C:\1\" ' <-- anpassen
Ordner2 = "C:\2\" ' <-- anpassen

Set UE = ThisWorkbook.Worksheets("Übersicht")

For i = 1 To 4
    ChDrive "C:"   ' <-- anpassen
   
    If i < 3 Then
        ChDir Ordner1
    Else
        ChDir Ordner2
    End If
   
    Datei = Application.GetOpenFilename("Excel Dateien (*.xls*), *.xls*")
    If Datei <> False Then
        Set WB = Workbooks.Open(Datei)
    Else
        GoTo Fehler
    End If
   
    With WB
        With Worksheets(1)
            .Range("C4:C13").Copy: UE.Range("B2").Offset(0, i - 1).PasteSpecial xlPasteValues
            .Range("C22:C39").Copy: UE.Range("B14").Offset(0, i - 1).PasteSpecial xlPasteValues
            .Range("D22:D39").Copy: UE.Range("B35").Offset(0, i - 1).PasteSpecial xlPasteValues
            .Range("E22:E39").Copy: UE.Range("B56").Offset(0, i - 1).PasteSpecial xlPasteValues
            .Range("C46:C67").Copy: UE.Range("B77").Offset(0, i - 1).PasteSpecial xlPasteValues
            .Range("E46:E67").Copy: UE.Range("B102").Offset(0, i - 1).PasteSpecial xlPasteValues
        End With
       
        With Worksheets(2)
            .Range("B2:B77").Copy: UE.Range("I2").Offset(0, i - 1).PasteSpecial xlPasteValues
            .Range("C2:C77").Copy: UE.Range("O2").Offset(0, i - 1).PasteSpecial xlPasteValues
        End With
    End With
   
    WB.Close Savechanges:=False
Next i
Exit Sub

Fehler:
MsgBox "User hat Abbrechen gedrückt."
End Sub