Hallo Patrick,
kopiere die folgenden Makros so wie sie hier sehen in ein Standard-Modul deiner Arbeitsmappe, in die die Daten importiert werden sollen:
Sub Import()
Dim Antwort
Dim arrDateien As Variant
Dim lngZeile As Long
Dim lngEZeile As Long
Dim lngLZeile As Long
Dim lngEinfZeile As Long
Dim lngESpalte As Long
Dim lngTab As Long
Dim lngRet As Long
Dim lngIndex As Long
Dim lngZaehler As Long
Dim d As Long
Dim strMonat As String
Dim strPfad As String
Dim strFile As String
Dim objFiles() As Object
Dim wkbQuelle As Workbook
Dim wshZiel As Worksheet
Dim rngErgebnis As Range
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
'Benachrichtigungen ausschalten
Application.DisplayAlerts = False
'Zieltabelle festlegen
Set wshZiel = ThisWorkbook.ActiveSheet
'einzulesender Monat aus Tabelle einlesen
strMonat = ActiveSheet.Range("D4").Value
'Pfad einlesen
strPfad = ActiveSheet.Range("D2").Value
Pruefen:
'Prüfen, ob Pfadangabe existiert
If strPfad = "" Then
Antwort = MsgBox("In Zelle D4 ist kein Pfad angegeben! Möchten Sie jetzt einen Pfad auswählen?", 36, "Pfad fehlt")
If Antwort = vbNo Then
'Makro beenden
MsgBox "Abbruch durch den Benutzer!", 16, "Makro beenden"
Exit Sub
Else
'Pfad abfragen
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Bitte das Hauptverzeichnis wählen"
.InitialFileName = ""
.InitialView = msoFileDialogViewThumbnail
.ButtonName = "OK"
If .Show = -1 Then strPfad = .SelectedItems(1)
End With
GoTo Pruefen
End If
End If
'Alle Excel-Dateien aus den Unterverzeichnissen einlesen
'nur Excel-Dateien einlesen
strFile = "*.xls*"
'Function zum Einlesen der Datei aufrufen
lngRet = FileSearchINFO(objFiles, strPfad, strFile, True)
If lngRet > 0 Then
'Array für die einzulesenden Dateien redimensionieren
ReDim arrDateien(lngRet)
'Nun die einzelnen Datein einlesen
For lngIndex = 0 To lngRet - 1
'nur Dateien aus den Unterordnern einlesen
If objFiles(lngIndex).ParentFolder.Path <> strPfad Then
'Pfad und Dateiname zusammensetzen und in Array schreiben
arrDateien(lngZaehler) = objFiles(lngIndex).ParentFolder.Path & "\" & objFiles(lngIndex).Name
lngZaehler = lngZaehler + 1
End If
Next lngIndex
End If
'Zaehler um 1 verringern, da letztes Element leer ist
lngZaehler = lngZaehler - 1
'alle gefundenen Datei durchlaufen
For d = 0 To lngZaehler
'Tabelle zum einlesen öffnen
Set wksQuelle = Workbooks.Open(arrDateien(d))
'einzelne Tabellenblätter durchlaufen
With wksQuelle
For lngTab = 1 To .Worksheets.Count
'Tabellen mit richtigem Monat suchen
If Left$(.Worksheets(lngTab).Name, 7) = strMonat Then
With .Worksheets(lngTab)
'letzte beschriebene Zeile in Spalte A (= letzte zu kopierende Zeile) ermitteln
lngLZeile = .Cells(Rows.Count, 1).End(xlUp).Row
'in Spalte A die Überschrift Name suchen
With .Range("A:A")
Set rngErgebnis = .Find("Name", LookIn:=xlValues, lookat:=xlPart)
End With
lngEZeile = rngErgebnis.Row + 1
'Suchergebnis zurücksetzen
Set rngErgebnis = Nothing
'Spalte KU Anteil suchen
With .UsedRange
Set rngErgebnis = .Find("KU Anteil", LookIn:=xlValues, lookat:=xlPart)
End With
'eine Spalte weiter = 1. Spalte der Kalendereintragungen
lngESpalte = rngErgebnis.Column + 1
'Suchergebnis zurücksetzen
Set rngErgebnis = Nothing
'erste Einfügezeile festlegen
lngEinfZeile = wshZiel.Cells(Rows.Count, 1).End(xlUp).Row + 1
'Daten kopieren - nur Formate und Werte
'Spalte A bis K
.Range(.Cells(lngEZeile, 1), .Cells(lngLZeile, 11)).Copy
With wshZiel.Cells(lngEinfZeile, 1)
.PasteSpecial Paste:=xlPasteValues 'Werte
.PasteSpecial Paste:=xlPasteFormats 'Formate
End With
'Eintragungen in Kalender kopieren
.Range(.Cells(lngEZeile, lngESpalte), .Cells(lngLZeile, lngESpalte + 31)).Copy
With wshZiel.Cells(lngEinfZeile, lngESpalte)
.PasteSpecial Paste:=xlPasteValues 'Werte
.PasteSpecial Paste:=xlPasteFormats 'Formate
End With
End With
End If
Next lngTab
'Quelldatei ohne speichern schließen
wksQuelle.Close (False)
End With
Next d
'Zum Abschluss die Formeln noch unten kopieren
'dazu die neue letzte Zeile ermitteln
With wshZiel
lngLZeile = .Cells(Rows.Count, 1).End(xlUp).Row
'Spalten L bis P
.Range(.Cells(lngEZeile, 12), .Cells(lngLZeile, 16)).FillDown
'Spalten AV bis CA oder AW bis CC
'falls in Zelle AV eine Formel steht, dann im Bereich AV bis CA die Formeln nach unten kopieren
If .Cells(lngEZeile, 48).HasFormula = True Then .Range(.Cells(lngEZeile, 48), .Cells(lngLZeile, 79)).FillDown
'falls in Zelle AW eine Formel steht, dann im Bereich AW bis CC die Formeln nach unten kopieren
If .Cells(lngEZeile, 49).HasFormula = True Then .Range(.Cells(lngEZeile, 49), .Cells(lngLZeile, 81)).FillDown
End With
'Benachrichtigungen einschalten
Application.DisplayAlerts = True
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
End Sub
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)
Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant
Set fobjFSO = CreateObject("Scripting.FileSystemObject")
Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
On Error GoTo ErrExit
If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
ReDim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
ReDim Preserve Files(UBound(Files) + 1)
Else
ReDim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next
If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function
Um das Makro aufzurufen, weise den Commandbuttons in den einzelnen Blättern den folgenden Code zu:
Private Sub CommandButton1_Click()
Call Import
End Sub
Schau mal wie das funktioniert. Je nach Anzahl der Dateien kann das etwas dauern. Teste erst einmal mit drei oder vier Dateien in den Unterverzeichnissen.
Gruß
M.O.