Excel Makro zum Einfügen von Daten aus anderen Excel Dateien

Option Explicit

Private Const RowStartA = 13                'Daten ab Zeile 13  

Private Const ColDataA = "B:F"              'Daten(A): B:F  
Private Const ColDataB = "D,B,E,D"          'Daten(B): D->B, E->D  
Private Const ColDataC = "E,C,J,E,K,F"      'Daten(C): E->C, J->E, K->F  

Public Sub DataImport()
    Dim oWkbB As Workbook, oWkbC As Workbook
    Dim oWksA As Worksheet, oWksB As Worksheet, oWksC As Worksheet
    Dim sFileB As Variant, sFileC As Variant
    Dim oCell As Range, oCells As Range, oFound As Range
    
    'Wahlweise einen anderen Ordnerpfad in Form "X:\Folder" angeben  
    ChDir ThisWorkbook.Path
    
    'Import-Dateiauswahl(B/C) *.xlsx-Dateien, bei Bedarf entsprechend anpassen  
    sFileB = Application.GetOpenFilename("Excel-Datei(B) (*.xlsx), *.xlsx")  
    sFileC = Application.GetOpenFilename("Excel-Datei(C) (*.xlsx), *.xlsx")  
    
    If sFileB = False Or sFileC = False Then
        MsgBox "Dateiauswahl unvollständig!", vbInformation, "Dateiauswahl . . ."  
        Exit Sub
    End If
    
    Set oWkbB = GetObject(sFileB)           'Set/Open Datei(B)  
    Set oWkbC = GetObject(sFileC)           'Set/Open Datei(C)  
    
    Set oWksA = ThisWorkbook.Sheets(1)      'Set Workbook(A)-Sheet1  
    Set oWksB = oWkbB.Sheets(1)             'Set Workbook(B)-Sheet1  
    Set oWksC = oWkbC.Sheets(1)             'Set Workbook(C)-Sheet1  

    With oWksA  'Daten-Bereich festlegen (A13:A??)  
          Set oCells = .Range(.Cells(RowStartA, "A"), .Cells(RowStartA, "A").End(xlDown))  
    End With

    Application.ScreenUpdating = False
    
    For Each oCell In oCells    'Alle Zellen(A13:A??) durchlaufen  
        If oCell.Text <> "" Then  
            With oWksA.Rows(oCell.Row)  'Aktuelle Zeile Spalte(B:F) Inhalte löschen  
                .Columns(ColDataA).ClearContents
            End With
            
            With oWksB.Columns("A:A")   'Datei(B) Spalte A durchsuchen  
                Set oFound = .Find(oCell.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
            End With
        
            If Not oFound Is Nothing Then   'Datei(B): Wenn gefunden Daten kopieren  
                Call GetValues(oWksA, oWksB, ColDataB, oCell.Row, oFound.Row)
            End If
            
            With oWksC.Columns("A:A")   'Datei(C) Spalte A durchsuchen  
                Set oFound = .Find(oCell.Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
            End With
            
            If Not oFound Is Nothing Then   'Datei(C): Wenn gefunden Daten kopieren  
                Call GetValues(oWksA, oWksC, ColDataC, oCell.Row, oFound.Row)
            End If
        End If
    Next
    
    oWkbB.Close False   'Datei(B) schließen (speichern=False)  
    oWkbC.Close False   'Datei(C) schließen (speichern=False)  
    
    Application.ScreenUpdating = True
    
    MsgBox "Fertig!", vbInformation, "Datenimport . . ."  
End Sub

Private Sub GetValues(ByRef oWksA, ByRef oWksX, ByRef sCols, ByVal iRowA As Long, ByVal iRowX As Long)
    Dim aColumns As Variant, i As Integer
    
    aColumns = Split(sCols, ",")  
    
    With oWksX.Rows(iRowX)
        For i = 0 To UBound(aColumns) Step 2
            oWksA.Cells(iRowA, aColumns(i + 1)).Value = .Columns(aColumns(i)).Value
        Next
    End With
End Sub