AW: Mehrere Excel-Dateien aus einem Verzeichnis einles
27.10.2003 16:22:16
Dan
Hallo Diethard,
versuch es mit diesem Code, startet mit Proc MehrereDateienAuslesen. Pfad musst du aber selber im Code eingeben. Tschuss, Dan (dusek@cb.vakjc.cz)
Option Explicit
Private Const Verz$ = "D:\" ' Daten\test
Private Const BereichZumKopieren$ = "a1 : a12"
Private Const ExLetzteZeile& = 65536
Private Const GesamttabelleName$ = "Gesamttabelle.xls"
Private Gesamttabelle As Workbook
Public
Sub MehrereDateienAuslesen() ' Starting Proc
Dim Fso As FileSystemObject
Dim Fld As Folder
Dim Fl As File, FlNr%
On erro GoTo ErrH
Set Gesamttabelle = Excel.Workbooks.Add
Gesamttabelle.SaveAs ("Gesamttabelle.xls")
Set Fso = New FileSystemObject
Set Fld = Fso.GetFolder(Verz$)
FlNr% = 0
For Each Fl In Fld.Files
If (Right(Fl.Name, 3) = "xls" And _
Fl.Name <> GesamttabelleName$) Then FlNr% = FlNr% + 1: Call DateiBeareiten(Fl, FlNr%)
Next Fl
Application.DisplayAlerts = True
Exit Sub
ErrH:
MsgBox "Laufzeitsfehler " & Err.Description
End Sub
Public
Sub DateiBeareiten(ByVal Datei As File, ByVal DateiNr%)
Dim WrbAktuell As Workbook, RngZumKop As Range
Static InZeile&
On Error GoTo ErrH
Set WrbAktuell = Excel.Workbooks.Open(Datei.Path)
' Daten aus aktuellen Workbook-Sheet1 ins Gesamttabelle kopieren
Set RngZumKop = WrbAktuell.Worksheets(1).Range(BereichZumKopieren$)
If (DateiNr% = 1) Then InZeile& = 0
If (InZeile& = 0) Then
RngZumKop.Copy Gesamttabelle.Worksheets(1).Range("a1")
InZeile& = RngZumKop.Rows.Count + 1
Else
If (InZeile& + RngZumKop.Rows.Count <= ExLetzteZeile&) Then
RngZumKop.Copy Gesamttabelle.Worksheets(1).Cells(InZeile&, 1)
InZeile& = InZeile& + RngZumKop.Rows.Count
Else
MsgBox "Nicht genugend Zeilen. Ende.": End
End If
End If
Application.DisplayAlerts = False
WrbAktuell.Close
Set WrbAktuell = Nothing
Exit Sub
ErrH:
If (Err.Number = 1004) Then ' Protected Workbook, schlechtes Passw.
If (MsgBox("Password ist fals, nochmalsversuchen???", vbYesNo + vbCritical) = vbYes) Then
Resume
Else
If (Not WrbAktuell Is Nothing) Then WrbAktuell.Close
Exit Sub
End If
Else
MsgBox "Laufzeitsfehler " & Err.Description
If (Not WrbAktuell Is Nothing) Then WrbAktuell.Close
End If
End Sub