AW: Kopiere ersten .sheets, anfügen in neuer Mapp
15.11.2015 13:29:54
Exel
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]