AW: Bestimmte Zeilen aus mehreren Dateien auslesen
12.01.2010 10:41:23
fcs
Hallo mari,
hier meine Makro-Lösung erstellt unter Excel 2003 - sollte aber auch unter 2007 laufen.
Gruß
Franz
Sub DatenImportieren()
Dim sVerzeichnis$, sDatei$
Dim wbZiel As Workbook, wbQuelle As Workbook
Dim wksZiel As Worksheet, wksQuelle As Worksheet
Dim ZeileZ&, FileCount&
Dim Zelle As Range
Const StartZelle$ = "G6" '1. Auszulesende Zelle in Tabelle 1
Const Schritt& = 3 'Spaltenabstand der auszulesenden Zellen
On Error GoTo Fehler
'Suchverzeichnis auswahlen
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Ordner mit zu durchsuchenden Dateien wählen"
.ButtonName = "Auswälen"
If .Show = -1 Then
sVerzeichnis = .SelectedItems(1)
sDatei = Dir(sVerzeichnis & Application.PathSeparator & "*.xl*")
If sDatei "" Then
'neue Datei mit einem Tabellenblatt für Ergebnisdaten erstellen
Set wbZiel = Workbooks.Add(Template:=xlWBATWorksheet)
'Zieltabellenblatt Objektvariable zuweisen
Set wksZiel = wbZiel.Worksheets(1)
ZeileZ = 1
With wksZiel
'Titelzeile ausfüllen
.Cells(ZeileZ, 1) = "Info"
.Cells(ZeileZ, 2) = "Stück"
.Cells(ZeileZ, 3) = "Dateiname"
End With
End If
Application.ScreenUpdating = False
Do Until sDatei = ""
FileCount = FileCount + 1
Application.StatusBar = "Datei, laufende Nr. " & FileCount & " wird bearbeitet."
'Quelldatei schreibgeschützt öffnen
Set wbQuelle = Workbooks.Open( _
Filename:=sVerzeichnis & Application.PathSeparator & sDatei, _
ReadOnly:=True)
'Tabelle1 Objektvariable zuweisen
Set wksQuelle = wbQuelle.Worksheets(1)
'Werte aus Blatt 1 auslesen
Set Zelle = wksQuelle.Range(StartZelle)
Do Until IsEmpty(Zelle)
If Zelle.Value 0 Then
ZeileZ = ZeileZ + 1
With wksZiel
'Info aus Zeile 1 eintragen
.Cells(ZeileZ, 1) = wksQuelle.Cells(1, Zelle.Column).Value
'Stückzahl eintragen
.Cells(ZeileZ, 2) = Zelle.Value
'Dateiname eintragen
.Cells(ZeileZ, 3) = sDatei 'gespeicherter Dateiname
' .Cells(ZeileZ, 3) = wksQuelle.Cells(1, 1).Value 'Dateinem in A1 des Quellblatts
End With
End If
'Nächste Zelle setzen
Set Zelle = Zelle.Offset(0, Schritt)
Loop
wbQuelle.Close savechanges:=False
Set wksQuelle = Nothing
Set wbQuelle = Nothing
sDatei = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Alle Dateien ausgelesen"
End If
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
Application.ScreenUpdating = True
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wbQuelle Is Nothing Then wbQuelle.Close savechanges:=False
End Select
End With
Set wbZiel = Nothing
Set wbQuelle = Nothing
Application.StatusBar = False
End Sub