AW: suchen-ersetzen in mehreren Dateien
15.03.2005 08:26:53
marcl
Hallo Pascal,
Habe 2 Makros für Dich, die ich mal von Ramses bekam und ein wenig geändert habe.
Sub Write_All_ExcelFiles_in_worksheet()
' listet Dir alle Dateien in Unterordnern als Hyperelink auf
Application.ScreenUpdating = False
'by Ramses
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
Application.ScreenUpdating = True
oldStatus = Application.StatusBar
On Error GoTo myErrHandler
Dateiform = "*.xls" ' zu suchende Dateiform
If Dateiform = "" Then
Application.ScreenUpdating = True
Exit Sub
End If
With Application.FileSearch
.LookIn = "H:\Eigene Dateien" 'Dein Ordnerpfad, wo die Unterordner drinn sind
.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
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 umbenennen ' lieber serstmal bis hier laufen lassen und dann Tabelle nachsehen
End Sub
Sub umbenennen()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Range("a1").Select
For i = 1 To 90000
zell = ActiveCell.Address
Range(zell).Offset(1, 0).Select
pfadname = ActiveCell
Workbooks.Open Filename:=pfadname 'Öffnet jede Datei in der Liste
On Error GoTo err
Dim Sh As Worksheet
For Each Sh In Worksheets ' mit jedem Blatt in der Datei
Sh.Activate
Range("A1") = "Deine Überschrift" ' Deine Überschrift in Zelle A1 eintragen
ActiveWorkbook.Save
ActiveWorkbook.Close
Next Sh
Next i
Exit Sub
err:
Application.Quit
End Sub
Wenn Du das Hochkomma vor call wegnimmst, laufen beide Makros nacheinander.
Gruß
Marcl