Hallo,
füge das folgende Makro in ein allgemeines Modul deiner Arbeitsmappe "Mitarbeiterstunden" ein. Ich gehe mal davon aus, die einzulesenden Tabellen immer gleich aufgebaut sind (Arbeitsmappenname beginnt immer mit 3stelliger Nummer, Tabellenname immer Monatszahl zweistellig am Ende, Datum immer Zeile 11 und Produktivität immer Zeile 40, erstes Datum ab Spalte F).
Nach dem Start wirst du aufgefordert, die einzulesende Datei und den einzulesenden Monat auszuwählen.
Sub import()
Dim wkbQuelle As Workbook
Dim wksQuelltab As Worksheet
Dim a As Integer
Dim w As Integer
Dim intProdnr As Integer
Dim intMonat As Integer
Dim Datei As Variant
Dim Rueck As Variant
Dim bExists As Boolean
Dim arrProd(30, 1) As Variant
Dim Suche As Range
'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")
'ausgewählte Datei öffnen
Workbooks.Open (Datei)
'Quelldatei an Variable zuweisen
Set wkbQuelle = ActiveWorkbook 'geöffnete Datei
'Produktnummer in variable schreiben
intProdnr = CInt(Left(wkbQuelle.Name, 3))
Eingabe:
'zu importierenden Monat abfragen; nur Zahlen als Eingabe zulassen
intMonat = Application.InputBox("Bitte geben Sie den zu importierenden Monat als Zahl (1 - 12) ein!", "Eingabe Monat", Type:=1)
'Prüfen, ob gültige Eingabe gemacht wurde
If intMonat < 1 Or intMonat > 12 Then
'Falls nicht, dann Nachfrage, ob neuer Versuch
Rueck = MsgBox("Ungültige Eingabe! Bitte wählen Sie eine Zahl zwischen 1 und 12 aus! Erneute Eingabe des Monats gewünscht?", 20, "Unzulässige Eingabe")
If Rueck = vbNo Then
'Abbruch, falls nein gedrückt wurde
Exit Sub
Else
'ansonsten neuer Versuch
GoTo Eingabe
End If
End If
'Prüfen, ob Monat in Quelldatei existiert
With wkbQuelle
For w = 1 To .Worksheets.Count
If CInt(Right(.Worksheets(w).Name, 2)) = intMonat Then
Set wksQuelltab = .Worksheets(w)
bExists = True
Exit For
End If
Next w
End With
'Fehlermeldung, falls Monat nicht gefunden wurde
If bExists = False Then
MsgBox "Der Monat " & intMonat & " wurde nicht gefunden! Abbruch!", 16, "Fehler"
Exit Sub
End If
'Daten aus Quelldatei in Array einlesen
With wksQuelltab
'Inhalte der Spalten F bis AJ in Array einlesen
For w = 6 To 36
arrProd(w - 6, 0) = .Cells(11, w) 'Datum
arrProd(w - 6, 1) = .Cells(40, w) 'Produktivitivität
Next w
End With
'Quelldatei wieder schließen - ohne Speicherung
wkbQuelle.Close (False)
With ThisWorkbook.ActiveSheet
'Produktnummer suchen
For w = 12 To 15
If .Cells(2, w).Value = intProdnr Then Exit For
Next w
For a = LBound(arrProd, 1) To UBound(arrProd, 1)
'Daten aus Array in Tabelle schreiben
'Nur Daten aus dem betreffenden Monat einfügen
If arrProd(a, 0) <> "" And Month(arrProd(a, 0)) = intMonat Then
'Datum suchen
Set Suche = .Range("A:A").Find(arrProd(a, 0), LookIn:=xlValues)
'Falls Datum gefunden, dann Produktivität eintragen
If Not Suche Is Nothing Then .Cells(Suche.Row, w) = arrProd(a, 1)
End If
Next a
End With
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
End Sub
Gruß
M.O.
