Thema: Kopiere ersten .sheets, anfügen in neuer Mapp

Hallo Sepp,
Ich habe es schon ein wenig angepasst und mit meinen alten Daten funktioniert es auch mit den Indirekt sachen was ich vor habe soweit, dieses sind jedoch nur 5 Dateien die mir mit

lngRes = FileSearchINFO(objFiles, strPath, "*.xls", True)

Problemlos angezeigt werden.
Wie jedoch erwähnt habe ich depp natürlich die neuen schon im .xlsx format, warum auch immer... verwende office 2010, und könnte die Dateien auch im 97 format speichern, was sich aber dann hinzieht wie eine Gurke :)
Meine befürchtung ist wenn dann alle .xl* formate eingelesen werden dann auch die Kunden Datei und die eigentliche Vorlage mit kopiert werden.
Aber leider funktionert die von dir vorgeschlagene änderung

lngRes = FileSearchINFO(objFiles, strPath, "*.xls*", True)

nicht... er macht den anschein als würde er mir die 6 alten dateien öffnen.

' **********************************************************************
' Modul: Modul5 Typ: Allgemeines Modul
Option Explicit
Sub Löschen()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
If ws.Name Like "RE" & "*" Then
If ThisWorkbook.Sheets.Count = 1 Then
MsgBox "Kann nicht gelöscht werden"
Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
End If
Next
End Sub
Sub Erstellen()
Dim objFiles() As Object
Dim objWB As Workbook
Dim strPath As String
Dim lngIndex As Long, lngRes As Long
On Error GoTo ErrorHandler
Static CalculationMode As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
CalculationMode = .Calculation
.Calculation = xlManual
.DisplayAlerts = False
End With
strPath = "C:\Users\Dana\Desktop\Dana\Abrechnung" 'Start-Verzeichnis - Anpassen!
lngRes = FileSearchINFO(objFiles, strPath, "*.xls*", True)
If lngRes <> 0 Then
For lngIndex = 0 To UBound(objFiles)
Set objWB = Workbooks.Open(objFiles(lngIndex).Path)
objWB.Sheets(1).COPY After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = "RE" & lngIndex + 1
objWB.Close False
Next
End If
ErrorHandler:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'copySheets'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - copySheets"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalculationMode
.DisplayAlerts = True
.StatusBar = False
End With
End Sub
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional  _
ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" _
findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard= _
False)
Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant
Set fobjFSO = CreateObject("Scripting.FileSystemObject")
Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
On Error GoTo ErrExit
If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
ReDim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
ReDim Preserve Files(UBound(Files) + 1)
Else
ReDim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next
If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function

grüsse john
[edit] Hab im Editor mal auf zurücksetzen gemacht und nochmal gestartet, er macht rein garnix :( [/edit]

Hallo John,
kommt eine Fehlermeldung? Kann das nicht nachvollziehen.

Nein, es passiert einfach garnix!

' **********************************************************************
' Modul: Modul5 Typ: Allgemeines Modul
Option Explicit
Sub Löschen()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
If ws.Name Like "RE" & "*" Then
If ThisWorkbook.Sheets.Count = 1 Then
MsgBox "Kann nicht gelöscht werden"
Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
End If
Next
End Sub
Sub Kopieren()
Dim objFiles() As Object
Dim objWB As Workbook
Dim strPath As String
Dim lngIndex As Long, lngRes As Long
On Error GoTo ErrorHandler
Static CalculationMode As Long
With Application
.ScreenUpdating = False
.Application.AskToUpdateLinks = False
.EnableEvents = False
CalculationMode = .Calculation
.Calculation = xlManual
.DisplayAlerts = False
End With
strPath = "C:\Users\Dana\Desktop\Dana\Abrechnung" 'Start-Verzeichnis - Anpassen!
lngRes = FileSearchINFO(objFiles, strPath, "*.xls", True)
If lngRes <> 0 Then
For lngIndex = 0 To UBound(objFiles)
Set objWB = Workbooks.Open(objFiles(lngIndex).Path)
objWB.Sheets(1).COPY After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = "RE" & lngIndex + 1
objWB.Close False
Next
End If
ErrorHandler:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'copySheets'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - copySheets"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalculationMode
.DisplayAlerts = True
.StatusBar = False
End With
End Sub
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional  _
ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" _
findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard= _
False)
Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant
Set fobjFSO = CreateObject("Scripting.FileSystemObject")
Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
On Error GoTo ErrExit
If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
ReDim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
ReDim Preserve Files(UBound(Files) + 1)
Else
ReDim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next
If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function
Sub Start()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
If ws.Name Like "RE" & "*" Then
If ThisWorkbook.Sheets.Count = 1 Then
MsgBox "Kann nicht gelöscht werden"
Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
End If
Next
Call Kopieren
End Sub

Hab es jetzt ein wenig angepasst das wenn ich es Starte er mir die RE Blätter löscht und dann das Kopieren anfängt (hier habe ich auch in deinem Makro geändert das er keine Fehlermeldung gibt wenn es externe verlinkung vorhanden sind), oder aber ich auswählen kann das nur die RE gelöscht werden!
Das Problem war aber auch schon mit der ersten Version von dir und die änderung, leider!
grüsse john

Hallo John,
hast du Excel schon mal beendet und neu gestartet?

Hallo Sepp,
anscheind funktioniert es jetzt mit der änderung...
Danke erst mal ganz herzlichst soweit!
Nun ist es so das aufgrund des formats einige Dateien mit eingelesen werden die nicht mit rein sollen!
Ich habe dann im netz etwas gefunden und etwas angepasst, aber leider bekomme ich es nicht zum laufen...
Denke das die $vars nicht passen, wie müsste es richtig heissen?

If lngRes <> 0 Then
For lngIndex = 0 To UBound(objFiles)

  If Not lngIndex Like "Datei1*" Or lngIndex Like "Datei2*" Then   '"Mappe*"
If Not SourceFolder.Path & "\" & lngIndex = ThisWorkbook.FullName Then Workbooks.Open SourceFolder.Path & "\" & lngIndex

    Set objWB = Workbooks.Open(objFiles(lngIndex).Path)
objWB.Sheets(1).COPY After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = "RE" & lngIndex + 1
objWB.Close False
Next
End If

grüsse John

Hmm, ich scheitere an der angabe der richtigen Variablen! :(
*verzweifeltguck*
Grüsse John

Hallo Sepp,
Ich habe es schon ein wenig angepasst und mit meinen alten Daten funktioniert es auch mit den Indirekt sachen was ich vor habe soweit, dieses sind jedoch nur 5 Dateien die mir mit

lngRes = FileSearchINFO(objFiles, strPath, "*.xls", True)

Problemlos angezeigt werden.
Wie jedoch erwähnt habe ich depp natürlich die neuen schon im .xlsx format, warum auch immer... verwende office 2010, und könnte die Dateien auch im 97 format speichern, was sich aber dann hinzieht wie eine Gurke :)
Meine befürchtung ist wenn dann alle .xl* formate eingelesen werden dann auch die Kunden Datei und die eigentliche Vorlage mit kopiert werden.
Aber leider funktionert die von dir vorgeschlagene änderung

lngRes = FileSearchINFO(objFiles, strPath, "*.xls*", True)

nicht... er macht den anschein als würde er mir die 6 alten dateien öffnen.

' **********************************************************************
' Modul: Modul5 Typ: Allgemeines Modul
Option Explicit
Sub Löschen()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
If ws.Name Like "RE" & "*" Then
If ThisWorkbook.Sheets.Count = 1 Then
MsgBox "Kann nicht gelöscht werden"
Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
End If
Next
End Sub
Sub Erstellen()
Dim objFiles() As Object
Dim objWB As Workbook
Dim strPath As String
Dim lngIndex As Long, lngRes As Long
On Error GoTo ErrorHandler
Static CalculationMode As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
CalculationMode = .Calculation
.Calculation = xlManual
.DisplayAlerts = False
End With
strPath = "C:\Users\Dana\Desktop\Dana\Abrechnung" 'Start-Verzeichnis - Anpassen!
lngRes = FileSearchINFO(objFiles, strPath, "*.xls*", True)
If lngRes <> 0 Then
For lngIndex = 0 To UBound(objFiles)
Set objWB = Workbooks.Open(objFiles(lngIndex).Path)
objWB.Sheets(1).COPY After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = "RE" & lngIndex + 1
objWB.Close False
Next
End If
ErrorHandler:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'copySheets'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - copySheets"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalculationMode
.DisplayAlerts = True
.StatusBar = False
End With
End Sub
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional  _
ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" _
findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard= _
False)
Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant
Set fobjFSO = CreateObject("Scripting.FileSystemObject")
Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
On Error GoTo ErrExit
If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
ReDim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
ReDim Preserve Files(UBound(Files) + 1)
Else
ReDim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next
If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function

grüsse john
[edit] Hab im Editor mal auf zurücksetzen gemacht und nochmal gestartet, er macht rein garnix :( [/edit]

Hallo John,
kommt eine Fehlermeldung? Kann das nicht nachvollziehen.

Nein, es passiert einfach garnix!

' **********************************************************************
' Modul: Modul5 Typ: Allgemeines Modul
Option Explicit
Sub Löschen()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
If ws.Name Like "RE" & "*" Then
If ThisWorkbook.Sheets.Count = 1 Then
MsgBox "Kann nicht gelöscht werden"
Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
End If
Next
End Sub
Sub Kopieren()
Dim objFiles() As Object
Dim objWB As Workbook
Dim strPath As String
Dim lngIndex As Long, lngRes As Long
On Error GoTo ErrorHandler
Static CalculationMode As Long
With Application
.ScreenUpdating = False
.Application.AskToUpdateLinks = False
.EnableEvents = False
CalculationMode = .Calculation
.Calculation = xlManual
.DisplayAlerts = False
End With
strPath = "C:\Users\Dana\Desktop\Dana\Abrechnung" 'Start-Verzeichnis - Anpassen!
lngRes = FileSearchINFO(objFiles, strPath, "*.xls", True)
If lngRes <> 0 Then
For lngIndex = 0 To UBound(objFiles)
Set objWB = Workbooks.Open(objFiles(lngIndex).Path)
objWB.Sheets(1).COPY After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = "RE" & lngIndex + 1
objWB.Close False
Next
End If
ErrorHandler:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'copySheets'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - copySheets"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalculationMode
.DisplayAlerts = True
.StatusBar = False
End With
End Sub
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional  _
ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" _
findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard= _
False)
Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant
Set fobjFSO = CreateObject("Scripting.FileSystemObject")
Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
On Error GoTo ErrExit
If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
ReDim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
ReDim Preserve Files(UBound(Files) + 1)
Else
ReDim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next
If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function
Sub Start()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
If ws.Name Like "RE" & "*" Then
If ThisWorkbook.Sheets.Count = 1 Then
MsgBox "Kann nicht gelöscht werden"
Else
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
End If
Next
Call Kopieren
End Sub

Hab es jetzt ein wenig angepasst das wenn ich es Starte er mir die RE Blätter löscht und dann das Kopieren anfängt (hier habe ich auch in deinem Makro geändert das er keine Fehlermeldung gibt wenn es externe verlinkung vorhanden sind), oder aber ich auswählen kann das nur die RE gelöscht werden!
Das Problem war aber auch schon mit der ersten Version von dir und die änderung, leider!
grüsse john

Hallo John,
hast du Excel schon mal beendet und neu gestartet?

Hallo Sepp,
anscheind funktioniert es jetzt mit der änderung...
Danke erst mal ganz herzlichst soweit!
Nun ist es so das aufgrund des formats einige Dateien mit eingelesen werden die nicht mit rein sollen!
Ich habe dann im netz etwas gefunden und etwas angepasst, aber leider bekomme ich es nicht zum laufen...
Denke das die $vars nicht passen, wie müsste es richtig heissen?

If lngRes <> 0 Then
For lngIndex = 0 To UBound(objFiles)

  If Not lngIndex Like "Datei1*" Or lngIndex Like "Datei2*" Then   '"Mappe*"
If Not SourceFolder.Path & "\" & lngIndex = ThisWorkbook.FullName Then Workbooks.Open SourceFolder.Path & "\" & lngIndex

    Set objWB = Workbooks.Open(objFiles(lngIndex).Path)
objWB.Sheets(1).COPY After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = "RE" & lngIndex + 1
objWB.Close False
Next
End If

grüsse John

Hmm, ich scheitere an der angabe der richtigen Variablen! :(
*verzweifeltguck*
Grüsse John