nacheinander verschiedene Dateien auslesen
13.02.2017 17:04:21
Kian
ich stelle mich grade irgendwie zu blöd an -.- Vllt könnt ihr mir helfen.
Das Modul sucht sich in einem Verzeichnis eine Datei, öffnet diese, kopiert gewisse
Einträge und schließt diese dann wieder. Funktioniert alles einwandfrei. Das Ziel ist aber das nicht nur für eine Datei durchzuführen, sondern für mehrere . Es muss also irgendwie eine Schleife implementiert werden, wofür ich mich aber grade als zu doof rausstelle :/
Anbei der Code vom Modul. Könnt ihr mir da helfen? Zusätzlich kommt als Problem hinzu, dass die auszulesenden Dateien jeweils einzeln in einem Unterordner liegen... Müsste also wie folgt ablaufen:
Überodner
-->unterordner + Modul anwenden
-->zurück zum Überordner
-->nächster Unterordner
Geht das irgendwie?!
Public Sub DatenAkt()
Dim Pfad, MPC, nZeile, cZeile, Dateiname, Quelle, Ziel, Ende As String
Quelle = "Datenbank"
Ziel = "Daten"
' MPC Dateiname als Variable übergeben
MPC = ActiveWorkbook.Name
' Ermitteln der letzten freien Zeile zum Einfügen
nZeile = Workbooks(MPC).Sheets(Ziel).Cells(Rows.Count, 2).End(xlUp).Row + 1
' Deaktivieren von Makros beim Auslesen der Dateien
' Funktion läuft im Hintergrund ab
Application.ScreenUpdating = False
Application.EnableEvents = False
' Pfad des Verzeichnisses und Dateiart für den Datenimport
Pfad = "C:\Users\Mohtachem\Desktop\Kian Mohtachem\03_Aufgaben\01_Projekte\IMX\05_MPC\ _
Schnittstelle RKA\"
Dateiname = Dir(Pfad & "*.xls")
' Öffnen der Exceldatei und kopieren der Datenbank
Workbooks.Open Filename:=Pfad & Dateiname
' Kopieren der Spalten Datum, Projektname, Projektnummer, Reisemittel, Berater, Betrag
With Workbooks(Dateiname).Sheets(Quelle)
' Ermitteln der letzten Zeile zum Kopieren
cZeile = Workbooks(Dateiname).Sheets(Quelle).Cells(Rows.Count, 13).End(xlUp).Row
.Range("B8:B" & cZeile).Copy
Workbooks(MPC).Sheets(Ziel).Range("B" & nZeile).PasteSpecial Paste:=xlPasteValues
.Range("N8:N" & cZeile).Copy
Workbooks(MPC).Sheets(Ziel).Range("C" & nZeile).PasteSpecial Paste:=xlPasteValues
.Range("K8:K" & cZeile).Copy
Workbooks(MPC).Sheets(Ziel).Range("D" & nZeile).PasteSpecial Paste:=xlPasteValues
.Range("C8:C" & cZeile).Copy
Workbooks(MPC).Sheets(Ziel).Range("E" & nZeile).PasteSpecial Paste:=xlPasteValues
.Range("O8:O" & cZeile).Copy
Workbooks(MPC).Sheets(Ziel).Range("F" & nZeile).PasteSpecial Paste:=xlPasteValues
.Range("M8:M" & cZeile).Copy
Workbooks(MPC).Sheets(Ziel).Range("G" & nZeile).PasteSpecial Paste:=xlPasteValues
End With
' Zieldatei ohne Speichern schließen
Workbooks(Dateiname).Close savechanges:=False
Application.CutCopyMode = False
' Schaltet das sichtbare Arbeiten und Makros wieder ein
Application.ScreenUpdating = True
Application.EnableEvents = True
'Kopierte Einträge formatieren
Ende = Workbooks(MPC).Sheets(Ziel).Cells(Rows.Count, 1).End(xlUp).Row
With Workbooks(MPC).Sheets(Ziel)
.Range("B6:B" & Ende).NumberFormat = "dd.mm.yyyy"
.Range("A6:G" & Ende).HorizontalAlignment = xlCenter
End With
End Sub
Beste Grüße,
Kian
