AW: Blätter kopieren
Marcel
Ich hoffe, Du arbeitest nicht in einem Netzwerk.
Hier sind 3 Codes, die verschachtelt sind. Kopiere alles zusammen in ein Modul.
Ich habe den Sprung zum 2. Makro gestoppt.
' Call copy
Wie man die Makros startet, ist bekannt?
Nun wenn das erste Makro durch ist, schau Dir die Tabelle an. Dort sind alle Excelfiles als Hyperlink aufgelistet.
Wenn die Dateien korrekt sind, kann das 2. Makro gestartet werden.
Sollte alles gut sein, kann man das Hochkomma '
bei ' Call copy wegnehmen. Dann laufen alle 3 Makros durch.
Ich bin ab heute in Urlaub.
Bei Fragen bitte an:
hardmarcsebay@aol.com
Gruß
Marcel
Sub Write_All_ExcelFiles_in_worksheet()
' Listet alle Dateien in einer Exceltabelle auf
Application.ScreenUpdating = False
'by Ramses
Dim myFSO As Object
Dim myDrvList, myDrv, mySpace
Dim Dateiform As String, myStr As String
Dim geffile As String
Dim i As Long, totFiles As Long, chkHype As Integer
Dim oldStatus As Variant
Set myFSO = CreateObject("Scripting.Filesystemobject")
Set myDrvList = myFSO.drives
Application.ScreenUpdating = True
oldStatus = Application.StatusBar
On Error GoTo myErrHandler
Dateiform = "*.xls"
If Dateiform = "" Then
Application.ScreenUpdating = True
Exit Sub
End If
For Each myDrv In myDrvList
If myDrv.IsReady Then
With myDrvList
myStr = "" & myDrv.DriveLetter & " - "
If myDrv.drivetype = 3 Then
myStr = myStr & myDrv.sharename & ": "
Else
myStr = myStr & myDrv.volumename & ": "
End If
Set mySpace = myFSO.getdrive(myFSO.getdrivename(myDrv.DriveLetter & ":"))
End With
With Application.FileSearch
' alle Ordner in C durchsuchen
.LookIn = "C:"
.LookIn = mySpace
.SearchSubFolders = True 'True für Suche in allen Unterverzeichnissen!!
.Filename = Dateiform
If .Execute() > 0 Then
totFiles = .FoundFiles.Count
Application.StatusBar = "Total " & totFiles & " in " & mySpace & " gefunden "
For i = 1 To .FoundFiles.Count
geffile = .FoundFiles(i)
'In Tabelle eintragen
Cells([A65536].End(xlUp).Row + 1, 1) = geffile
ActiveSheet.Hyperlinks.Add Anchor:=Cells([A65536].End(xlUp).Row, 1), Address:=geffile _
, TextToDisplay:=geffile
Selection.Font.ColorIndex = 2
Next i
End If
End With
End If
Next
ErrEntry:
Application.StatusBar = oldStatus
Application.ScreenUpdating = True
MyExit:
Close #1
Exit Sub
myErrHandler:
Select Case err
Case 71
myStr = myStr & "Datenträger nicht bereit"
End Select
Resume ErrEntry
'Call copy
End Sub
Sub copy()
' legt eine neue Datei an, in der die Blätter angelegt werden
Quelldatei = ActiveWorkbook.Name
Workbooks.Add
'Neue Mappe speichern unter "C:\Eigene Dateien\.......xls"
datei = InputBox("Name der Datei?")
ActiveWorkbook.SaveAs Filename:="C:\Eigene Dateien\" & datei & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
MsgBox ("Die Datei wurde unter 'C:\Eigene Dateien\" & datei & ".xls' gespeichert")
Zieldatei = ActiveWorkbook.Name
Windows(Quelldatei).Activate
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Range("a1") = 1
Range("a1").Select
Call such
End Sub
Sub such()
' sucht Alle Dateien nach dem Blatt "Eingabe" und kopiert den gesamten Inhalt in die Zieldatei
Quelldatei = ActiveWorkbook.Name
ActiveWindow.WindowState = xlMinimized
Zieldatei = ActiveWorkbook.Name
Windows(Quelldatei).Activate
ActiveWindow.WindowState = xlMaximized
Do While ActiveCell <> ""
For i = 1 To 90000
zell = ActiveCell.Address
Range(zell).Offset(1, 0).Select
pfadname = ActiveCell
Workbooks.Open Filename:=pfadname
On Error GoTo err
Sheets("Eingabe").Select
' Blatt kopieren und in 2. Datei alle Werte einfügen
Cells.copy
Windows(Zieldatei).Activate
Cells.Select
ActiveSheet.Paste
Sheets.Add
Range("a1").Select
Windows(Quelldatei).Activate
Next i
Loop
Exit Sub
err:
ActiveWindow.Close
Windows(Quelldatei).Activate
Call such
End Sub