Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA: Sheet suchen und kopieren/verschieben

VBA: Sheet suchen und kopieren/verschieben
17.10.2016 12:11:31
jnschmitt
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

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

Betreff
Datum
Anwender
Anzeige
AW: VBA: Sheet suchen und kopieren/verschieben
17.10.2016 13:21:14
ChrisL
Hi
Sub OpenFiles()
Dim strPfad As String
Dim kst As Range
strPfad = "C:\Pfad"
Set kst = ActiveSheet.Range("B4")
Call ListFilesInFolder(strPfad, kst)
End Sub

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

Das Grundgerüst habe ich von hier:
http://www.office-loesung.de/ftopic498569_0_0_asc.php
cu
Chris
Anzeige
AW: VBA: Sheet suchen und kopieren/verschieben
17.10.2016 13:36:18
jnschmitt
hi Chris,
Das sieht gut aus.
Er öffnet auch die Dateien im Verzeichnis, aber das passende sheet wird nicht kopiert.
Ich versuche dem Grund auf schliche zu kommen.
Aber das hilft mir schon sehr weiter, Danke
AW: VBA: Sheet suchen und kopieren/verschieben
17.10.2016 13:46:27
jnschmitt
edit: Problem liegt nicht am Code sondern an meiner Tabelle.
In einer leeren mappe funktioniert er tadellos.
bin gespannt ob ich den fehler finde.
AW: VBA: Sheet suchen und kopieren/verschieben
17.10.2016 13:48:39
ChrisL
Hi
Danke für die Rückmeldung. Vielleicht ein Formatierungsproblem, probiere mal...
If WS.Name = kst.Text Then
cu
Chris
AW: VBA: Sheet suchen und kopieren/verschieben
17.10.2016 14:27:53
jnschmitt
Hi,
ein speichern und wieder öffnen hat wunder bewirkt.
habe es mit .Value gemacht
was ich micht jetzt noch frage, kann ich ich meine gefunden sheets, ja habe es schon um kstB erweitert ;) , direkt überschreiben lassen, falls sie in der Zieldatei schon vorhanden sind?
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
VG
Schmitt
Anzeige
AW: VBA: Sheet suchen und kopieren/verschieben
17.10.2016 15:07:28
ChrisL
Hi
Vielleicht einfacher, wenn du existierende WS einfach löschst.
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
cu
Chris
AW: VBA: Sheet suchen und kopieren/verschieben
17.10.2016 15:16:26
jnschmitt
ah jetzt seh ich auch warum meine Or Verbindung nicht funktioniert hat.
Perfekt danke dir.
VG
Schmitt

343 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige