AW: Daten und Tabellen aus Arbeitsmappen auslesen
22.02.2011 23:12:34
fcs
Hallo René,
hier dein Makro angepasst an deine Wunschliste. das FileSearch-Objekt existiert unter Excel 2007 nicht mehr. Ich hab es durch "Dir" in Kombination mit einer Do-Loop-Schleife ersetzt.
Die aus der Übersicht auszulesenden Zellen sind jetzt in einem Array festgelegt. Das ermöglicht das "einfache" abarbeiten in einer For-Next-Schleife.
Für die Daten aus dem Blatt Abrechnung wird "einfach" ein 2. Blatt in der Daei angelegt und per Copy und PasteSpecial jeweils der Inhalt aus dem Bereich A6:J30 übertragen.
Speichere das Makro im VBA-Projekt bitte in einem allgemeinen Modul - nicht unter "DieseArbeitsmappe". Es kann sonst zu Problemen bei der Makroausführung kommen.
Gruß
Franz
'Erstellt/überarbeitet unter Excel 2007
Sub Import_Kassabuchdaten()
Dim wbKM As Workbook, wb As Workbook, wksQuelle As Worksheet
Dim wksKM As Worksheet, wksAbr As Worksheet
Dim Verzeichnis As Variant, DateiName As String, ZellBereich$, arrZellen
Dim i As Integer, ZeileKM As Long, ZeileAbr As Long, Spalte As Long
'Neue Mappe anlegen
Set wbKM = Workbooks.Add(Template:=xlWBATWorksheet)
Set wksKM = wbKM.Worksheets(1)
Range("B2").Select
ActiveWindow.FreezePanes = True
'Blatt für Abrechnungsdaten einfügen
wbKM.Worksheets.Add After:=wbKM.Sheets(wbKM.Sheets.Count)
Set wksAbr = wbKM.Sheets(2)
Range("A2").Select
ActiveWindow.FreezePanes = True
'Verzeichnis auswählen
With Application.FileDialog(msoFileDialogFolderPicker) 'Hier Verzeichnis anpassen
.Title = "Verzeichnis für Dateien des Monats auswählen"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewDetails
If .Show = 0 Then Exit Sub
Verzeichnis = .SelectedItems(1)
End With
'auszulesende Zellen
arrZellen = Array("C5", "C7", "C11", "C13", "C15", "C17", "C19", "C21", "C24", _
"b98", "C43", "D43", "E43", "H43", "F43", "G43", "P45", "Q45", "R45", "s45", "t45", _
"v45", "C104", "B109", "D107", "E107", "F107", "G107", "B2")
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
DateiName = Dir(Verzeichnis & Application.PathSeparator & "*.xls")
With wksKM
ZeileKM = 1 'Zeile für Spaltentitel in der Tabelle in der Daten eingetragen werden
.Name = "Übersichtsdaten"
Spalte = 1
.Cells(ZeileKM, Spalte) = "Dateiname"
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle1" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle2" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle3" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle4" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle5" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle6" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle7" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle8" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle9" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle10" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle11" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle12" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle13" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle14" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle15" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle16" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle17" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle18" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle19" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle20" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle21" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle22" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle23" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle24" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle25" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle26" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle27" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle28" & "-" & arrZellen(Spalte - 2)
Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle29" & "-" & arrZellen(Spalte - 2)
' Spalte = Spalte + 1: .Cells(ZeileKM, Spalte) = "Zelle30" & "-" & arrZellen(Spalte - 2)
.Columns(2).NumberFormat = "#,##0" ' Beispiel(deutsch): 2.000
End With
With wksAbr
.Name = "Abrechnung"
Spalte = 1
ZeileAbr = 1
'Spaltentitel für Blatt Abrechnung
.Cells(ZeileAbr, Spalte) = "Spalte 1"
Spalte = Spalte + 1: .Cells(ZeileAbr, Spalte) = "Spalte 2"
Spalte = Spalte + 1: .Cells(ZeileAbr, Spalte) = "Spalte 3"
Spalte = Spalte + 1: .Cells(ZeileAbr, Spalte) = "Spalte 4"
Spalte = Spalte + 1: .Cells(ZeileAbr, Spalte) = "Spalte 5"
Spalte = Spalte + 1: .Cells(ZeileAbr, Spalte) = "Spalte 6"
Spalte = Spalte + 1: .Cells(ZeileAbr, Spalte) = "Spalte 7"
Spalte = Spalte + 1: .Cells(ZeileAbr, Spalte) = "Spalte 8"
Spalte = Spalte + 1: .Cells(ZeileAbr, Spalte) = "Spalte 9"
Spalte = Spalte + 1: .Cells(ZeileAbr, Spalte) = "Zelle10"
ZeileAbr = 2
End With
Do Until DateiName = ""
Application.StatusBar = "Datei " & DateiName & " wird bearbeitet"
Set wb = Workbooks.Open(Filename:=Verzeichnis & Application.PathSeparator _
& DateiName, ReadOnly:=True)
'Übersichtsdaten übertragen
Set wksQuelle = wb.Worksheets(1)
ZeileKM = ZeileKM + 1
Spalte = 1
wksKM.Cells(ZeileKM, 1).Value = wb.Name ' oder wb.FullName, wenn mit Verzeichnis
For i = LBound(arrZellen) To UBound(arrZellen)
Spalte = Spalte + 1
wksKM.Cells(ZeileKM, Spalte).Value = wksQuelle.Range(arrZellen(i))
Next
'Abrechnungsdaten übertragen
Set wksQuelle = wb.Worksheets("Abrechnung")
wksQuelle.Range("A6:J30").Copy
wksAbr.Cells(ZeileAbr, 1).PasteSpecial Paste:=xlPasteFormats
wksAbr.Cells(ZeileAbr, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'Nächste Einfüge Zeile
ZeileAbr = ZeileAbr + 25
'Quelldatei wieder schliessen
wb.Close savechanges:=False
'Nächste Quelldatei
DateiName = Dir
Loop
Application.StatusBar = False
'Spaltenbreite optimal einstellen
wksKM.Columns.AutoFit
'Beschleunigungseinstellungen zueücksetzen
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Dialogs(xlDialogSaveAs).Show
End Sub