AW: Daten kopieren aus mehreren Dateien
06.11.2003 13:28:16
Dan
' Hallo Torsten,
' wie gross der Bereich ist, z.B so ermitteln :
Public
Sub BereichErmiteln()
Dim rBereich As Range
' in dem Bereich durfen keine leere Spalten oder leere Zeilen vorhanden sein
Set rBereich = Application.ActiveSheet.Range("a4").CurrentRegion
rBereich.Activate
End Sub
' ----------------------------------------------------------------------------------
' Die letzte Zeile z.B. mit dieser simplen Funktion ermitteln :
Option Explicit
Public
Function GetLastFreeCellRow(ByVal Wsh As Worksheet, _
Optional ByVal StartCol As Integer = 1, _
Optional ByVal StartRow As Long = 1) As Long
On Error GoTo ErrH
With Wsh
Do While (.Cells(StartRow, StartCol).Value <> "")
StartRow = StartRow + 1
Loop
End With
GetLastFreeCellRow = StartRow
Exit Function
ErrH:
MsgBox "
Function LastFreeCellRow() : " & vbCrLf & "Laufzeitsfehler Nr. " & Err.Number & ". " & Err.Description
GetLastFreeCellRow = 0
End Function
Public
Sub Test_GetLastFreeCellRow()
Dim LastFreeCellRow&
' die Suche beginnt in der Spalte StartCol und in der Zeile StarRow, und im Sheet Wsh
LastFreeCellRow& = GetLastFreeCellRow(Wsh:=ActiveSheet, StartCol:=6, StartRow:=15)
If (LastFreeCellRow& > 0) Then
Cells(LastFreeCellRow&, 1).Activate
Else
' last row not found
End If
End Sub
' ---------------------------------------------------------------------------------------
' Vor nicht langer Zeit habe ich etwas ehliches fur einen anderen Forum-Besucher
' gemacht, hier der Code (vielleich kann es fur dich nutzlich sein. Mfg Dan
' dusek@cb.vakjc.cz) :
Option Explicit
' Makro startet man mit der Proc MehrereDateienAuslesen(). Einfach im Excel Alt+F8 drucken und den Namen MehrereDateienAuslesen auswahlen
' und auf Taste Run drucken...
' Makro bildet eine neue Datei mit dem Namen GesamttabelleName$ (jetzt "Gesamttabelle.xls")
' In diese Datei werden die Daten aus den bearbeiteten Dateien, aus dem Bereich BereichZumKopieren$ (jetzt "a1 : a12") kopiert
' Die bearbeiteten Dateine werden aus Verzeichnis Verz$ (jetzt "D:\Daten\test") geoffnet
' Falls man etwas ander braucht, z.B. den Bereich, muss man einfach die Const BereichZumKopieren$ andern. Z.B. so :
' Private Const BereichZumKopieren$ = "b1 : b10" - jetzt wird immer der Bereich "b1 : b10" ausgelesen und in die Datei
' "Gesamttabelle.xls" kopiert.
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 Error GoTo ErrH
Set Gesamttabelle = Excel.Workbooks.Add
Gesamttabelle.SaveAs (Verz$ & "\" & GesamttabelleName$)
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
MsgBox "Das Makro hat den Verzeichnis <" & Verz$ & "> durchgesucht." & vbCrLf & _
"Es sind " & FlNr% & " Excel Dateien bearbeitet worden."
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, nochmals versuchen???", 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