Sheets aus mehreren Tabellen

Public Function BrowseForFolder(DialogText As String, _
DefaultPath As String, _
OwnerhWnd As Long, _
Optional ShowCurrentPath As Boolean = True, _
Optional RootPath As Variant, _
Optional NewDialogStyle As Boolean = False, _
Optional IncludeFiles As Boolean = False) As String
' Parameter:
' o DialogText Dialogtext, der oben im Dialog angezeigt wird.
' o DefaultPath Standardmäßig ausgewähltes Verzeichnis.
' o OwnerhWnd hWnd des übergeordneten Fensters (in den meisten
' Fällen Me.hWnd).
' o ShowCurrentPath Legt fest, ob die aktuelle Verzeichnisauswahl
' angezeigt werden soll. Verfügbar ab
' Internet Explorer 4.0 (-> PathCompactPath).
' o RootPath Root-Verzeichnis. Wird es angegeben, werden nur die
' Ordner unterhalb dieses Verzeichnisses angezeigt.
' o NewDialogStyle Legt fest, ob der Dialog in der neuen Darstellung
' angezeigt werden soll (Dialog kann vergrößert/
' verkleinert werden, es ist eine Schaltfläche zum
' Anlegen eines neuen Ordners vorhanden, es können
' Dateioperationen wie löschen etc. ausgeführt
' werden, ...). Ist dieser Parameter True, hat der
' Parameter ShowCurrentPath keine Wirkung. Verfügbar
' unter WinME und Betriebsystemen ab Win2000.
' o IncludeFiles Legt fest, ob auch Dateien im Dialog angezeigt und
' ausgewählt werden können.
' Verfügbar ab Win98 und Internet Explorer 4.0 (bei
' frühreren Windowsversionen muss IE4 inkl. der
' Integrated Shell installiert sein).
Dim biBrowseInfo As BROWSEINFO
Dim lPIDL As Long
Dim sBuffer As String
Dim lBufferPointer As Long
With biBrowseInfo
' Handle des übergeordneten Fensters
.hOwner = OwnerhWnd
' PIDL des Rootordners zuweisen
If Not IsMissing(RootPath) Then .pidlRoot = PathToPIDL(RootPath)
' Dialogtext zuweisen
If ShowCurrentPath And DialogText = "$" Then DialogText = "" ' Wird intern nicht zugelassen
.lpszTitle = DialogText
' Stringbuffer für aktuell selektierten Pfad zuweisen
If ShowCurrentPath Then .pszDisplayName = sBuffer
' Dialogeinstellungen zuweisen
.ulFlags = BIF_RETURNONLYFSDIRS + _
IIf(ShowCurrentPath, BIF_STATUSTEXT, 0) + _
IIf(NewDialogStyle, BIF_NEWDIALOGSTYLE, 0) + _
IIf(IncludeFiles, BIF_BROWSEINCLUDEFILES, 0)
' Callbackfunktion-Adresse zuweisen
.lpfnCallback = FARPROC(AddressOf CallbackString)
' PIDL des vorselektierten Ordnerpfades zuweisen (wird im
' lpData-Parameter an die Callback-Funktion weitergeleitet)
.lParam = PathToPIDL(DefaultPath)
End With
' BrowseForFolder-Dialog anzeigen
lPIDL = SHBrowseForFolder(biBrowseInfo)
If lPIDL Then
' Stringspeicher reservieren
sBuffer = Space$(MAX_PATH)
' Selektierten Pfad aus der zurückgegebenen PIDL ermitteln
SHGetPathFromIDList lPIDL, sBuffer
' Nullterminierungszeichen des Strings entfernen
sBuffer = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
' Selektierten Pfad zurückgeben
BrowseForFolder = sBuffer
' Reservierten Task-Speicher wieder freigeben
Call CoTaskMemFree(lPIDL)
End If
' Stringspeicher wieder freigeben
If ShowCurrentPath Then Call LocalFree(lBufferPointer)
End Function

Private Function CallbackString(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal lParam As Long, ByVal lpData As Long) As Long
' Callback-Funktion des BrowseForFolder-Dialogs. Wird bei
' eintretenden Ereignissen des Dialogs aufgerufen.
Dim sBuffer As String
Dim lStaticWnd As Long
Dim lStaticDC As Long
Dim sPath As String
Dim rctStatic As RECT
Dim szTextSize As Size
' Meldungen herausfiltern
Select Case uMsg
Case BFFM_INITIALIZED
' Dialog wurde initialisiert
' Standardmäßig markierten Pfad (dessen PIDL wurde in lpData
' übergeben) im Dialog selektieren
Call SendMessage(hwnd, BFFM_SETSELECTIONA, False, ByVal lpData)
Case BFFM_SELCHANGED
' Selektion hat sich geändert
' Stringspeicher reservieren
sBuffer = Space$(MAX_PATH)
' Aktuell selektierten Pfad ermitteln und anzeigen, wenn möglich
If SHGetPathFromIDList(lParam, sBuffer) Then
' Temporäre Zeichenfolge an das Anzeigelabel senden, um
' dessen Handle anhand dieser Zeichenfolge ermitteln zu können
SendMessage hwnd, BFFM_SETSTATUSTEXTA, 0&, ByVal "$"
' Handle und DeviceContext des Anzeigelabels ermitteln
lStaticWnd = FindWindowEx(hwnd, ByVal 0&, ByVal "Static", ByVal "$")
lStaticDC = GetWindowDC(lStaticWnd)
' Abmessungen des Anzeigelabels ermitteln
GetWindowRect lStaticWnd, rctStatic
' Textabmessungen der Zeichenfolge "Auswahl: " im Anzeigelabel
' ermitteln
GetTextExtentPoint lStaticDC, ByVal DIALOG_CURRENT_SELECTION_TEXT, _
ByVal Len(DIALOG_CURRENT_SELECTION_TEXT), szTextSize
' Anzuzeigenden Pfad auf die Abmessungen des Anzeigelabels
' kürzen; falls dies nicht möglich ist, gesamten Pfad anzeigen
sPath = sBuffer
If PathCompactPath(ByVal lStaticDC, sPath, ByVal (rctStatic.Right - _
rctStatic.Left - szTextSize.cx + 80)) = 0 Then sPath = sBuffer
' Nullterminierung entfernen
sPath = Left$(sPath, InStr(1, sPath, vbNullChar) - 1)
' Pfad im Dialog anzeigen
Call SendMessage(hwnd, BFFM_SETSTATUSTEXTA, 0&, _
ByVal DIALOG_CURRENT_SELECTION_TEXT & sPath)
Else
' Pfadanzeige leeren
SendMessage hwnd, BFFM_SETSTATUSTEXTA, 0&, ByVal ""
End If
End Select
End Function

Private Function FARPROC(FunctionPointer As Long) As Long
' Funktion wird benötigt, um Funktions-Adresse ermitteln
' zu können, dessen Adresse mit AddressOf übergeben und
' anschließend wieder zurückgegeben wird.
FARPROC = FunctionPointer
End Function

' Gibt die lPIDL zum übergebenen Pfad zurück.

Private Function PathToPIDL(ByVal sPath As String) As Long
Dim lRet As Long
lRet = ILCreateFromPath(sPath)
If lRet = 0 Then
sPath = StrConv(sPath, VbStrConv.vbUnicode)
lRet = ILCreateFromPath(sPath)
End If
PathToPIDL = lRet
End Function

Public Sub SearchFileAndCopySheet()
Dim objFS As FileSearch
Dim objFO As Object
Dim objWb As Workbook, objNew As Workbook
Dim strPath As String
Dim intIndex As Integer
Dim iCounter As Integer
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
.Cursor = xlWait
End With
strPath = BrowseForFolder("Quellverzeichnis auswählen", ThisWorkbook.Path, 0, , , False, False)
If strPath = "" Then GoTo ErrExit
If Right(strPath, 1)  "\" Then strPath = strPath & "\"
Set objFS = Application.FileSearch
Set objFO = CreateObject("Scripting.FileSystemObject")
'Set objNew = Workbooks("zusammen.xls")
With objFS
.NewSearch
.LookIn = strPath
.FileType = msoFileTypeExcelWorkbooks
.SearchSubFolders = False
If .Execute > 0 Then
For intIndex = 1 To .FoundFiles.Count
Set objWb = Workbooks.Open(.FoundFiles(intIndex))
Sheets("monat").Select
Workbooks("zusammen.xls").Activate
objWb.Sheets("Stunden").Move after:=Workbooks("zusammen.xls").Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = objFO.GetBasename(.FoundFiles(intIndex))
objWb.Close False
Set objWb = Nothing
Next
End If
End With
'objNew.Sheets(1).Delete
'objNew.SaveAs strPath & "Zusammenfassung.xls"
ErrExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.Cursor = xlDefault
End With
Set objNew = Nothing
Set objFS = Nothing
Set objFO = Nothing
End Sub

Der Sinn sollte sein, dass aus einem bestimmten Verzeichnis, aus mehreren Excel-Dateien, ein bestimmtes Blatt (heisst immer "monat") in eine vorhandene Datei (zusammen.xls) kopiert wird (bekommt dort den Namen der Datei aus der kopiert wurde) um dann weiterverarbeitet zu werden. Das klappt auch sehr gut, das Problem ist nur dass die Dateien in dem Verzeichnis nicht gleichzeitig dort liegen, sondern in zeitlichem Abstand. D.h. sie müssten nacheinander "eingelesen" werden (immer nur die die beim ersten Mal nicht da war). Bei obiger Prozedur wird immer wieder das ganze Verzeichnis eingelesen und die schon vorhandenen Blätter in der Zieldatei werden nicht berücksichtigt...... deshalb läuft das Ganze dann natürlich immer auf einen Fehler. Ich komme einfach nicht darauf wie ich das Ganze ändern muss, dass immer nur die neu hinzugekommenen Tabellen genommen werden.
Vielleicht geht das auch gar nicht? Wäre für einen Tipp wirklich dankbar.
Sorry für den langen Code, ich wusste nicht wie ich es sonst erklären soll :-))
Gruß
Bonnie