Office: Ersatzfunktion für application.filesearch

Olaf_Nieman · 19. Juni 2015

Hallo Forumsgemeine,

ich benötige bitte Hilfe bei der Ersatzsuche zu "Application.Filesearch".
Die Lösungsansätze sind zwar vielfältig, allerdings verstehe ich diese nicht.

Ich habe ein hier eine Art Sammelsheet vorliegen, welches in dem Ordner, wo die Datei gespeichert vorhandene vorhandene Excel-Dateien (die sind identisch aufgebaut) sucht und dort enthaltenen Inhalt zusammen kopiert

Code:

Sub BudgetBerechnen()

pfad = ActiveWorkbook.Path
sumdateiname = ActiveWorkbook.Name

Windows(sumdateiname).Activate

Set co = CreateObject("Scripting.FileSystemObject")
If co.folderexists(pfad) Then

With Application.Filesearch
.LookIn = pfad
.SearchSubFolders = False
.Filename = "*.xls"
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Die erste Frage ist, kann man jetzt eine Art Ersatzfunktion für Application.Filesearch erzeugen in einem Modul o.ä (Private Function) mit welcher
der vorhandene Code der Datei weiter abgearbeitet wird?

Die zweite Frage
Wie muss ich diesen Ersatzcode in meinem Sammelheet aufrufen,
damit der weitere Code weiter ausgeführt wird.

Ich bin für jede fachmännische Hilfe dankbar.

MfG

:)

Hajo_Zi · 21. Juni 2015

Ordner durchsuchen

xlph · 21. Juni 2015

Hallo,

wenn der Quellpfad bekannt ist, dann langt folgender Code:

Code:

Sub BudgetBerechnen()

Dim pfad As String
Dim dateiname As String

Dim SammelSheet As Worksheet

pfad = ThisWorkbook.Path & "\"
dateiname = Dir(pfad & "*.xls*")

Set SammelSheet = ThisWorkbook.Worksheets("Sammelsheet")

Application.ScreenUpdating = False

Do Until dateiname = vbNullString
If dateiname ThisWorkbook.Name Then

With Workbooks.Open(pfad & dateiname, 0, True)
.Worksheets(1).UsedRange.Offset(1).Copy _
Destination:=SammelSheet.Cells(SammelSheet.Rows.Count, 1).End(xlUp).Offset(1)
.Close SaveChanges:=False
End With

End If
dateiname = Dir()
Loop

Application.ScreenUpdating = True

Set SammelSheet = Nothing

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Olaf_Nieman · 23. Juni 2015

Hallo Forum,

ich danke sehr (sehr sehr) für die bisherigen Antworten.
Ich bin mit meinen Fragen in diesem Forum goldrichtig!

Das Beispiel von Hajo´s Excel Seiten kannte ich schon, war leider für mein Problem nicht verständlich genug, für einen VBA-Amateur, wie mich.

Der Code von "xlph" hat grundsätzlich prima funktioniert.

zu die diesem VBA-Code habe ich nachdem ich rausgefunden habe, dass die Sheets anhand ihrer Sortierreihenfolge im Excel angesprochen werden noch eine Frage:
Wie drücke ich aus, dass ich jeweils im Sheet10 "Planung" (nicht im ersten Sheet) die Daten von A1 bis S34 kopiert und dann ein Offset von ca. 2 Zeilen
die Daten von der nächsten Datei eingefügt werden.
Das funktioniert mit dem vorhandenen VBA-Code leider noch nicht.
Code:

Sub BudgetBerechnen()

Dim pfad As String
Dim dateiname As String

Dim SammelSheet As Worksheet

pfad = ThisWorkbook.Path & "\"
dateiname = Dir(pfad & "*.xls*")

Set SammelSheet = ThisWorkbook.Worksheets("Sammelsheet")

Application.ScreenUpdating = False

Do Until dateiname = vbNullString
If dateiname ThisWorkbook.Name Then

With Workbooks.Open(pfad & dateiname, 0, True)
.Worksheets(1).UsedRange.Offset(1).Copy _
Destination:=SammelSheet.Cells(SammelSheet.Rows.Count, 1).End(xlUp).Offset(1)
.Close SaveChanges:=False
End With

End If
dateiname = Dir()
Loop

Application.ScreenUpdating = True

Set SammelSheet = Nothing

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Ich danke auf jeden Fall noch einmal für die bisherigen Lösungsvorschläge

Das Beispiel von Herrn Hajo_Zi werde ich mir auf jeden Fall für zukünftige Probleme aufheben.

Danke

xlph · 24. Juni 2015

Code:

Sub BudgetBerechnen()

Dim pfad As String
Dim dateiname As String

Dim SammelSheet As Worksheet

pfad = ThisWorkbook.Path & "\"
dateiname = Dir(pfad & "*.xls*")

Set SammelSheet = ThisWorkbook.Worksheets("Sammelsheet")

Application.ScreenUpdating = False

Do Until dateiname = vbNullString
If dateiname ThisWorkbook.Name Then

With Workbooks.Open(pfad & dateiname, 0, True)
.Worksheets("Planung").UsedRange.Offset(1).Copy _
Destination:=SammelSheet.Cells(SammelSheet.Rows.Count, 1).End(xlUp).Offset(2)
.Close SaveChanges:=False
End With

End If
dateiname = Dir()
Loop

Application.ScreenUpdating = True

Set SammelSheet = Nothing

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Leerzeilen sollten eigentlich vermieden werden!

Olaf_Nieman · 25. Juni 2015

Danke erneut an xlph!

Funktioniert soweit prima. Eine Frag muss ich aber noch stellen:
Die zu kopierenden Daten aus den einzelnen Plannungssheets sind innerhalb
der einzelnen Dateien mittels diverser Formeln zusammen geführt.
Mit dem vorhandenen Code wird jeweils der komplette Zellinhalt kopiert, was im Sammelsheet zu Formelverweisen führt.

Wie muss der Code angepasst werden, dass nur die Werte aus dem Quellbereich kopiert werden?

Ich habe mit folgender Schleife probiert, funktioniert aber nicht als Schleife:
Code:

With Workbooks.Open(pfad & dateiname, 0, True)
Sheets("Planung").Select
Range("A1:R35").Select
Selection.Copy
Windows(sumdateiname).Activate
Sheets("Sammelsheet").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveCell.Offset(35, 0) = 0

.Close SaveChanges:=False
End With
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Ich schicke schon mal ein weiteres Dankeschön!

Mit freundlichen Grüßen

xlph · 25. Juni 2015

Code:

With Workbooks.Open(pfad & dateiname, 0, True)
.Worksheets("Planung").UsedRange.Offset(1).Copy
SammelSheet.Cells(SammelSheet.Rows.Count, 1).End(xlUp).Offset(2).PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Close SaveChanges:=False
End With
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

...müsste so funktionieren.

Olaf_Nieman · 27. Juni 2015

Erst einmal wiederum ein dickes Dankeschön an "xlph" für den freundlichen Support.

Die Anpassungen des VBA-Codes aus ihrem letzten Beitrag ermöglich im Wesentlichen das, was ich zu erstellen versuche.

Ich habe noch eine Frage zum besseren Verständnis was die Funktion macht:

Code:

With Workbooks.Open(pfad & dateiname, 0, True)
.Worksheets("Planung").UsedRange.Offset(1)
'
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

xlph · 27. Juni 2015

Hallo,

Warum werden dadurch am Anfang 2 Leerzeilen (Zeile 1+2) erzeugt?
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Code:

SammelSheet.Cells(SammelSheet.Rows.Count, 1).End(xlUp).Offset(2)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

1. Springe ausgehend von letzter Zeile in Spalte 1
2. zur nächsten gefüllten Zelle nach oben
3. Springe 2 Zeilen nach unten

Code:

Sub BudgetBerechnen()

Dim pfad As String
Dim dateiname As String

Dim SammelSheet As Worksheet

Dim ImportZaehler As Long
Dim PasteRowsOffset As Long

pfad = ThisWorkbook.Path & "\"
dateiname = Dir(pfad & "*.xls*")

Set SammelSheet = ThisWorkbook.Worksheets("Sammelsheet")

Application.ScreenUpdating = False

Do Until dateiname = vbNullString
If dateiname ThisWorkbook.Name Then

ImportZaehler = ImportZaehler + 1

If ImportZaehler = 1 Then
If WorksheetFunction.CountA(SammelSheet.UsedRange) = 0 Then
PasteRowsOffset = 0
Else
PasteRowsOffset = 1
End If
Else
PasteRowsOffset = 2
End If

With Workbooks.Open(pfad & dateiname, 0, True)
.Worksheets("Planung").UsedRange.Offset(1).Copy
SammelSheet.Cells(SammelSheet.Rows.Count, 1).End(xlUp).Offset(PasteRowsOffset).PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Close SaveChanges:=False
End With

End If
dateiname = Dir()
Loop

Application.ScreenUpdating = True

Set SammelSheet = Nothing

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Olaf_Nieman · 28. Juni 2015

OK, funktioniert! Besten Dank noch einmal!

Hoffentlich können noch andere von der von "xlph" geleisteten Entwicklungsarbeit profitieren.
Das Thema "application.filesearch" wird ja im Netz vielfältig diskutiert.

Vielen Dank für Die Hilfe und ein schönes Restwochenende!

Office: Ersatzfunktion für application.filesearch

Ersatzfunktion für application.filesearch

Ersatzfunktion für application.filesearch

Ersatzfunktion für application.filesearch

Ersatzfunktion für application.filesearch

Ersatzfunktion für application.filesearch - Similar Threads - Ersatzfunktion application filesearch

Application Guard für Office

Progressbar / Application-Anzeige

UserForm im Vordergrund halten wenn application visible=false

Filesearch funzt nicht mit Excel2007

Die Methode 'Run' für das Objekt 'Application' ist fehlgeschlagen

HILFE ! Word für Win 95 Application file funktioniert nicht mehr

Application hang