AW: Dateien zusammenfassen
03.06.2013 11:58:26
Klaus
Hi Holger,
für einen fixen Ordner geht es zB so:
Option Explicit
Sub MacheEineGrosseDateiAusVielenImOrdner()
Dim sFile As String, sPath As String
Dim wkbOld As Workbook
Dim wkbNew As Workbook
'hier DEINEN Pfad angeben!
sPath = "C:\TestTMP"
'grade aktives Workbook merken
Set wkbOld = ActiveWorkbook
'Pfadangabe bereinigen
If Right(sPath, 1) "/" Then
sPath = sPath & "\"
End If
'Dateiliste erstellen
sFile = Dir(sPath & "*.xls*") '.xls* öffnet xls, xlsx, xlsm usw ...
'Jede Datei im Pfad durchgehen
Do While sFile ""
'Datei öffnen
Workbooks.Open sPath & sFile
'Datei merken
Set wkbNew = ActiveWorkbook
'Tabelle ins alte Workbook kopieren
'es wird immer das AKTIVE sheet kopiert!
'da du schreibst, die Dateien haben nur ein Sheet, ist es das richtige.
ActiveSheet.Copy Before:=wkbOld.Sheets(1)
'Dateizähler hochsetzen
sFile = Dir()
'Datei schließen ohne zu speichern
wkbNew.Close False
Loop
Application.ScreenUpdating = True
End Sub
'*********************************************************************************************** _
'* Module to open needed files. Checks if Files are open or not.
'* If file is already open, do nothing - else open it
'* stolen from: https://www.herber.de/mailing/Pruefen_ob_Arbeitsmappe_geoeffnet_und_wenn_nein_oeffnen.htm
'* modified by Klaus Meyer von der Twer / 16.NOV.2012
'*********************************************************************************************** _
'Example:
'Call FileCheckOpen("C:\TMP", "Filename.xls")
'path and filename can be RANGE from excelsheet
Sub FileCheckOpen(sPath As String, sFile As String)
sPath = sPath & "/" & sFile
If WkbExists(sFile) = False Then
If Dir(sPath) = "" Then
MsgBox "File " & sPath & " not found!"
Else
Workbooks.Open sPath, UpdateLinks:=False
End If
Else
Workbooks(sFile).Activate
End If
End Sub
Function WkbExists(sFile As String) As Boolean
Dim wkb As Object
On Error Resume Next
Set wkb = Workbooks(sFile)
If Not wkb Is Nothing Then
WkbExists = True
End If
On Error GoTo 0
End Function
Function WksSheetExists(sSheet As String) As Boolean
Dim wks As Object
On Error Resume Next
Set wks = Sheets(sSheet)
If Not wks Is Nothing Then
WksSheetExists = True
End If
On Error GoTo 0
End Function
Die Pfadangabe dynamisiert bekommst du selber?
Grüße,
Klaus M.vdT.