Dateien in Verzeichnis - Hyperlinks entfernen
17.07.2012 01:02:08
fcs
Hallo Achim,
hier der Ausbau deines Makros für Dateien in einem Verzeichnis.
Gruß
Franz
Option Explicit
'Allgemeines Modul
'Erstellt unter Excel 2010, sollte unter Excel 2003 lauffähig sein
Sub DateilisteBearbeiten()
Dim Verzeichnis As Variant
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Verzeichnis mit den zu bearbeitenden Dateien azswählen"
.InitialView = msoFileDialogViewDetails
If .Show = -1 Then
Verzeichnis = .SelectedItems(1)
Application.ScreenUpdating = False
Call Dateiliste(strVerz:=Verzeichnis)
Application.ScreenUpdating = True
MsgBox "Fertig!", vbOKOnly, "Hyperlinks entfernen"
End If
End With
End Sub
Sub Dateiliste(ByVal strVerz As String)
Dim Datei As Object
Dim Ordner As Object
Dim FSO As Object
On Error Resume Next 'Überspringt Ordner/Datei für die kein Zugriff möglich
Set FSO = CreateObject("Scripting.filesystemobject")
For Each Datei In FSO.GetFolder(strVerz).Files
If LCase(Datei.Name) Like "*.xls*" Then
Call HyperlinksEntfernen(strDateiName:=Datei.Path)
End If
Next
For Each Ordner In FSO.GetFolder(strVerz).subfolders
Call Dateiliste(strVerz:=Ordner)
Next
Set FSO = Nothing
Set Ordner = Nothing
Set Datei = Nothing
End Sub
Sub HyperlinksEntfernen(ByVal strDateiName As String)
Dim rng As Range
Dim tbl As Worksheet
Dim wb As Workbook
Set wb = Application.Workbooks.Open(Filename:=strDateiName)
Application.StatusBar = "Bearbeite Datei """ & strDateiName & """"
For Each tbl In wb.Worksheets
For Each rng In tbl.UsedRange
With rng
If .Hyperlinks.Count > 0 Then
.Hyperlinks.Delete
.Value = Application.Substitute(.Value, "", "")
.NumberFormat = "#,##0.00 $"
With .Font
.Underline = xlUnderlineStyleNone
'.ColorIndex = xlColorIndexNone
End With
End If
End With
Next rng
Next tbl
wb.Close savechanges:=True
Application.StatusBar = False
End Sub