VBA: Sheet suchen und kopieren/verschieben

Hallo,
ich habe folgende Ausgangslage:
Ich habe ein Workbook A in dem steht auf der ersten Tabelle in Zelle "B4" ein eine 10-Stellige Nummer.
Daneben habe ich in einem Ordner c:\test eine bis 10 Exceldateien liegen mit sehr vielen sheets deren SheetName jeweils eine 10-Stellige Nummer ist.
Nun möchte ich alle Dateien im Ordner Test durchsuchen und den Sheetnamen mit der 10-Stelligen Nummer vergleichen ( mehrere sheets können die Nummer haben) und in mein Workbook A vor Tabelle 8 Kopieren und Einfügen.
Mein Ansatz bis jetzt:


Option Explicit
Dim objFileSystemObject     As Object
Dim objDateien              As Object
Dim objWeitereDateien       As Object
Dim objDatei                As Object
Dim ws                      As Worksheet
Sub Openfile_start()
Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set objDateien = objFileSystemObject.getfolder("c:\test")
Call file_suche
Set objFileSystemObject = Nothing
Set objDateien = Nothing
Application.StatusBar = ""
End Sub
Sub file_suche()
Application.ScreenUpdating = False
Set kst = Cells(4, 2)
For Each objDatei In objDateien.Files
If Right(objDatei.Name, 4) = ".xls" Or Right(objDatei.Name, 5) = ".xlsx" _
Or Right(objDatei.Name, 5) = ".xlsm" Then
Application.StatusBar = "Datei """ & objDatei.Name & """ wird ausgelesen!"
DoEvents
GetObject (objDatei)

hier fangen die Probleme an bzw. hier weiß ich nicht weiter


For Each ws In objDatei
If ws.Name Like kst Then
ThisWorkbook.Worksheets.Move Before:=ActiveWorkbook.Sheets(8)

dieser Teil sollte wieder Funktionieren


'Geöffnete Datei wieder schließen ohne zu speichern
Workbooks(objDatei.Name).Close SaveChanges:=False
End If
Next
End If
Next
For Each objWeitereDateien In objDateien.subfolders
Set objDateien = objWeitereDateien
Call file_suche
Next
End Sub

ich weiß nicht mit welcher Suche ich am Besten arbeite und wie ich diese Sinnig in VBA schreibe.
Ich hoffe ihr könnt mir helfen.
VG
Schmitt

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub ListFilesInFolder(SourceFolderName As String, kst As Range) Dim SourceFolder As Object, SubFolder As Object, NächsteMappe$ Dim WB As Workbook, WS As Worksheet Set SourceFolder = CreateObject("Scripting.FileSystemObject").GetFolder(SourceFolderName) NächsteMappe = Dir(SourceFolder.Path & "\*.XLS*") Do While NächsteMappe "" If Not UCase(SourceFolder.Path & "\" & NächsteMappe) = UCase(ThisWorkbook.FullName) Then Set WB = Workbooks.Open(SourceFolder.Path & "\" & NächsteMappe) For Each WS In WB.Worksheets If WS.Name = kst Then WS.Copy Before:=ThisWorkbook.Sheets(8) End If Next WS WB.Close False End If NächsteMappe = Dir() Loop For Each SubFolder In SourceFolder.SubFolders ListFilesInFolder SubFolder.Path, kst Next SubFolder Set SourceFolder = Nothing Set SubFolder = Nothing End Sub

Sub OpenFiles() Dim strPfad As String Dim kst As Range Dim kstB As Range strPfad = "c:\test" Set kst = ActiveSheet.Range("B4") Set kstB = ActiveSheet.Range("B5") Call ListFilesInFolder(strPfad, kst, kstB) End Sub Sub ListFilesInFolder(SourceFolderName As String, kst As Range, kstB As Range) Dim SourceFolder As Object, SubFolder As Object, NächsteMappe$ Dim WB As Workbook, WS As Worksheet Set SourceFolder = CreateObject("Scripting.FileSystemObject").GetFolder(SourceFolderName) NächsteMappe = Dir(SourceFolder.Path & "\*.XLS*") Do While NächsteMappe "" If Not UCase(SourceFolder.Path & "\" & NächsteMappe) = UCase(ThisWorkbook.FullName) Then Set WB = Workbooks.Open(SourceFolder.Path & "\" & NächsteMappe) For Each WS In WB.Worksheets If WS.Name = kst.Value Then WS.Copy Before:=ThisWorkbook.Sheets(8) End If If WS.Name = kstB.Value Then WS.Copy Before:=ThisWorkbook.Sheets(8) End If Next WS WB.Close False End If NächsteMappe = Dir() Loop For Each SubFolder In SourceFolder.SubFolders ListFilesInFolder SubFolder.Path, kst, kstB Next SubFolder Set SourceFolder = Nothing Set SubFolder = Nothing End Sub

If WS.Name = kst Or WS.Name = kstB Then On Error Resume Next Application.DisplayAlerts = False ThisWorkbook.Worksheets(WS.Name).Delete WS.Copy Before:=ThisWorkbook.Sheets(8) Application.DisplayAlerts = True End If

Beliebteste Forumthreads (12 Monate)

VBA: Sheet suchen und kopieren/verschieben

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

324 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA: Sheet suchen und kopieren/verschieben

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

324 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread