Hallo Rene,
der folgende Code gehört in ein allgemeines Modul deiner Arbeitsmappe (Zieltabelle):
Sub Import()
Dim Datei As Variant
Dim strNameQuelle As String
Dim arrQuelle As Variant
Dim lngMonat As Long
Dim lngTag As Long
Dim strZieltab As String
Dim i As Long
Dim bExists As Boolean
Dim arrUeberschrift As Variant
Dim u As Long
Dim q As Long
Dim z As Long
Dim lngEinfZeile As Long
Dim lngFehlerzeile As Long
Dim bFehler As Boolean
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
'Datei-Öffnen Dialog aufrufen
Datei = Application.GetOpenFilename(FileFilter:="Microsoft Excel-Dateien (*.xl*), *.xl*", Title:="EINE Datei zum Öffnen auswählen")
If Datei = False Then
'Makro abbrechen wenn Benutzer den Öffnen-Dialog abbricht
MsgBox "Der Benutzer hat abgebrochen.", vbInformation
Exit Sub
End If
'ausgewählte Datei öffnen
Workbooks.Open (Datei)
With ActiveWorkbook
'Namen der zu öffnenden Datei in Variable schreiben
strNameQuelle = .Name
'1. Arbeitsblatt in Quelldatei auswählen
With Worksheets(1)
'Daten in Array einlesen
arrQuelle = .Range(.Cells(1, 1), .Cells(.Cells(Rows.Count, 1).End(xlUp).Row, .UsedRange.SpecialCells(xlCellTypeLastCell).Column))
End With
'Quelldatei ohne Änderungen speichern
.Close (False)
End With
'Monat und Tag aus Dateinamen ermitteln
'Aufbau: V2_Tag_2019-01-24___xxx.xls
lngMonat = CLng(Mid(strNameQuelle, 13, 2))
lngTag = CLng(Mid(strNameQuelle, 16, 2))
'Zielarbeitsblatt anhand des Monats auswählen - Namen ggf. anpassen
Select Case lngMonat
Case 1: strZieltab = "Januar"
Case 2: strZieltab = "Februar"
Case 3: strZieltab = "März"
Case 4: strZieltab = "April"
Case 5: strZieltab = "Mai"
Case 6: strZieltab = "Juni"
Case 7: strZieltab = "Juli"
Case 8: strZieltab = "August"
Case 9: strZieltab = "September"
Case 10: strZieltab = "Oktober"
Case 11: strZieltab = "November"
Case 12: strZieltab = "Dezember"
End Select
'Zielarbeitsblatt in der Mappe suchen
For i = 1 To ThisWorkbook.Worksheets.Count
If Worksheets(i).Name = strZieltab Then
bExists = True
Exit For
End If
Next i
'Abbruch und Fehlermeldung, falls Zieltabelle nicht gefunden wurde
If bExists = False Then
MsgBox "Die Tabelle " & strZieltab & "wurde nicht gefunden! Abbruch", 16, "Fehler!"
Exit Sub
End If
'zum betreffenden Arbeitsblatt wechseln
With ThisWorkbook.Worksheets(i)
'Überschriften in Array einlesen
arrUeberschrift = .Range(.Cells(1, 1), .Cells(1, .UsedRange.SpecialCells(xlCellTypeLastCell).Column))
'für Einfügezeile das Datum in Spalte A durchsuchen
'ab Zeile 2 durchlaufen, da in 1. Zeiler überschriften stehen - ggf. anpassen
For z = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
'in Spalte A steht das Datum als 01.01. im Datumsformat (TT.MM)
If Day(.Cells(z, 1)) = lngTag Then
lngEinfZeile = z 'Einfügezeile in Variable schreiben
Exit For 'Schleife verlassen
End If
Next z
'nun die Daten aus der Quelldatei über einen Vergleich der Überschriften in das Zielblatt einfügen
'Quelle erst ab Zeile 2 durchlaufen, da in 1. Zeile Überschriften stehen
For q = 2 To UBound(arrQuelle, 1)
'Schalter für das Finden auf Falsch setzen
bExists = False
'Vergleich der Überschriften
For u = 1 To UBound(arrUeberschrift, 2)
If arrQuelle(q, 1) = arrUeberschrift(1, u) Then
bExists = True 'Schalter für Gefunden auf Wahr setzen
.Cells(lngEinfZeile, u) = arrQuelle(q, 2) 'Daten einfügen
End If
Next u
'Falls nicht gefunden, werden fehlerhafte Daten in ein Tabellenblatt Fehler geschrieben, das ggf. neu angelegt wird
If bExists = False Then
'Schalter für Fehler auf wahr setzen
bFehler = True
For z = 1 To ThisWorkbook.Worksheets.Count
If Worksheets(z).Name = "Fehler" Then
bExists = True
Exit For
End If
Next z
'falls Blatt nicht existiert, das Blatt anlegen
If bExists = False Then
'Neues Blatt wird am Ende eingefügt
Worksheets.Add After:=Worksheets(Worksheets.Count)
'Neues Blatt benennen
ActiveSheet.Name = "Fehler"
'Überschriften einfügen
Worksheets("Fehler").Cells(1, 1) = "Name der Quelltabelle"
Worksheets("Fehler").Cells(1, 2) = "Zeile Nr."
Worksheets("Fehler").Cells(1, 3) = arrQuelle(1, 1)
Worksheets("Fehler").Cells(1, 4) = arrQuelle(1, 2)
'Spaltenbreite automatisch festlegen
Worksheets("Fehler").Columns("A:D").EntireColumn.AutoFit
End If
'Einfügezeile im Fehlerblatt wird ermittelt
lngFehlerzeile = Worksheets("Fehler").Cells(Rows.Count, 1).End(xlUp).Row + 1
'Daten in das Fehlerblatt schreiben
Worksheets("Fehler").Cells(lngFehlerzeile, 1) = strNameQuelle
Worksheets("Fehler").Cells(lngFehlerzeile, 2) = q
Worksheets("Fehler").Cells(lngFehlerzeile, 3) = arrQuelle(q, 1)
Worksheets("Fehler").Cells(lngFehlerzeile, 4) = arrQuelle(q, 2)
End If
Next q
End With
'Falls Fehler vorhanden sind, auf das Arbeitsblatt mit den Fehlern wechseln
If bFehler = True Then Worksheets("Fehler").Activate
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
End Sub
Ich gehe davon aus, dass in der Zielarbeitsmappe das Datum in Spalte A im Datumsformat 01.01. eingetragen ist. Die Namen der Arbeitsblätter für die einzelnen Monate musst du ggf. anpassen.
Mit dem Ausführen des Makros wirst du aufgefordert die zu importierende Excel-Datei auszuwählen. Alles andere erfolgt über das Makro. Sollte ein Eintrag aus der zu importierenden Tabelle nicht einer Kategorie im Zielarbeitsblatt zugeordnet werden können, so wird dieser Eintrag in ein Fehlerblatt geschrieben (wird ggf. angelegt).
Gruß
M.O.