Option Explicit
Private Const cWBNAME_LINKSERSETZEN = STEUERDATEI_LINKSERSETZEN.xls
'Blatt->zu bearbeitende Dateien'
Private Const cWSD_NAME = DATEIEN
Private Const cWSD_Z_UEBSCHR = 1
Private Const cWSD_Z_ERSTEWERTEZEILE = cWSD_Z_UEBSCHR + 1
Private Const cWSD_SP_DATEINAMEN = 1
Private Const cWSD_SP_DATEINAMEN_TXT = zu bearbeitende Dateien
Private Const cWSD_DATEIENDUNGFILTER = .xls
'Blatt->zu bearbeitende Links'
Private Const cWSL_NAME = Zu bearbeitende links
Private Const cWSL_Z_UEBSCHR = 1
Private Const cWSL_Z_ERSTEWERTEZEILE = cWSL_Z_UEBSCHR + 1
Private Const cWSL_SP_LINK_ALT = 1
Private Const cWSL_SP_LINK_ALT_TXT = links alt
Private Const cWSL_SP_LINK_NEU = cWSL_SP_LINK_ALT + 1
Private Const cWSL_SP_LINK_NEU_TXT = links neu
'*************************************************************************************************
Sub LinksErsetzen()
'*** Erwartet eine Excel-Datei namens cWBNAME_LINKSERSETZEN im
'*** Pfad der Makro-Datei
'***
'*** Blatt cWSD_NAME - zu bearbeitendde Dateien
'*** und
'*** Blatt cWSD_NAME - zu bearbeitende/ersetzende links
'*** müssen vorhanden sein.
'***
'*** In allen zu bearbeitenden Dateien werden die links alt gesucht und durch den
'*** entsprechenden link neu ersetzt.
'***
Dim wb As Workbook, wb2 As Workbook, wsl As Worksheet, wsd As Worksheet, ws2 As Worksheet, h As Hyperlink
Dim sWBName As String, sWBPfad As String, sWSNameDatei As String, sWSNameLinks As String
Dim sFile As Variant, slink As String, z As Long, x As Long, sAddress As String
->a) Datei cWBNAME_LINKSERSETZEN öffnen.
->a1) Blatt cWSD_NAME setzen (Dateien-Blatt)
->a2) Blatt cWSL_NAME setzen (Link-Blatt)
sWBPfad = ThisWorkbook.Path
sWBName = cWBNAME_LINKSERSETZEN
sWSNameDatei = cWSD_NAME
sWSNameLinks = cWSL_NAME
If Not DateiOeffnenBlaetterSetzen(wb, wsd, wsl, _
sWBName, sWBPfad, _
sWSNameDatei, sWSNameLinks) Then GoTo AUFRAEUMEN
->alle Dateien
z = cWSD_Z_ERSTEWERTEZEILE - 1
Do
z = z + 1
sFile = wsd.Cells(z, cWSD_SP_DATEINAMEN).Value
If sFile = Then Exit Do
On Error Resume Next
Set wb2 = Workbooks.Open(FileName:=sFile)
If Err.Number <> 0 Then Err.Clear
On Error GoTo 0
If wb2 Is Nothing Then
MsgBox Datei & sFile & konnte nicht geöffnet werden.
GoTo AUFRAEUMEN
End If
For Each ws2 In wb2.Worksheets
For Each h In ws2.Hyperlinks
x = cWSL_Z_ERSTEWERTEZEILE - 1
Do
x = x + 1
slink = wsl.Cells(x, cWSL_SP_LINK_ALT).Value
If slink = Then Exit Do
sAddress = h.Address
If Left(sAddress, Len(file://)) = file:// Then
sAddress = Right(sAddress, Len(sAddress) - Len(file://))
End If
If slink = sAddress Then
On Error Resume Next
h.Address = wsl.Cells(x, cWSL_SP_LINK_NEU).Value
If Err.Number <> 0 Then
Err.Clear
MsgBox _
Ziel für folgenden link nicht vorhanden: & vbLf & _
wsl.Cells(x, cWSL_SP_LINK_NEU).Value & vbLf & _
Datei: & wb2.Name & vbLf & _
Blatt: & ws2.Name & vbLf & _
Zelle: & h.Range.Address(False, False)
On Error GoTo 0
GoTo AUFRAEUMEN
End If
On Error GoTo 0
End If
Loop
Next
Next
wb2.Close savechanges:=True
Loop
AUFRAEUMEN:
Set wb = Nothing: Set wb2 = Nothing: Set wsl = Nothing: Set wsd = Nothing: Set ws2 = Nothing: Set h = Nothing
End Sub
'*************************************************************************************************
Sub LinksErsetzen_BlattDateienErzeugen()
'*** Legt eine Excel-Datei namens cWBNAME_LINKSERSETZEN im
'*** Pfad der Makro-Datei an, wenn noch nicht vorhanden
'***
'*** Setzt ein neues Blatt cWSD_NAME in diese Arbeitsmappe.
'*** Wenn solch ein Blatt bereits vorhanden ist, wird nur der Inhalt gelöscht.
'***
'*** Im weiteren erfolgt eine Dateiauswahl (auch mehrfach) per Datei-Auswahl-Dialog.
'*** Diese Dateien werden der Reihe nach in der ersten Spalte abgelegt.
Dim wb As Workbook, ws As Worksheet
Dim sWBName As String, sWBPfad As String, sWSName As String
Dim vFile As Variant, z As Long, x As Long
->a) prüfen, ob cWBNAME_LINKSERSETZEN existiert.
-> wenn nein, Datei anlegen
->a1) Datei exisitiert nicht -> anlegen
->a21) prüfen, ob Datei bereits geöffnet ist
->a22) Datei nicht offen -> öffnen
->a3) Blattnamen prüfen, ggf neu anlegen
->a4) Blattnamen vergeben
sWBPfad = ThisWorkbook.Path
sWBName = cWBNAME_LINKSERSETZEN
sWSName = cWSD_NAME
If Not DateiUndBlattAnlegen(wb, ws, sWBName, sWBPfad, sWSName) Then GoTo AUFRAEUMEN
->b) Formatieren als Text
ws.Cells.NumberFormat = @
->c) Überschrift
With ws.Cells(cWSD_Z_UEBSCHR, cWSD_SP_DATEINAMEN)
.Value = cWSD_SP_DATEINAMEN_TXT: .Font.Bold = True
End With
->d) Dateien auswählen und in Spalte cWSD_SP_DATEINAMEN schreiben
z = cWSD_Z_ERSTEWERTEZEILE - 1
MsgBox _
Bitte wählen Sie mit dem nachfolgenden Datei-Dialog die zu bearbeitenden Dateien aus. & vbLf & _
Mehrfachselektion ist möglich.
Do
vFile = Application.GetOpenFilename(MultiSelect:=True)
If vbBoolean <> VarType(vFile) Then->bei Abbruch Boolean(False)
For x = LBound(vFile) To UBound(vFile)
z = z + 1
ws.Cells(z, cWSD_SP_DATEINAMEN).Value = vFile(x)
Next
End If
If vbNo = MsgBox(Wollen Sie weitere Dateien auswählen ?, _
vbQuestion + vbDefaultButton1 + vbYesNo) Then Exit Do
Loop
->e) Nachbearbeitung
->e1) sortieren
If z > cWSD_Z_ERSTEWERTEZEILE Then
ws.Range(ws.Cells(cWSD_Z_ERSTEWERTEZEILE, cWSD_SP_DATEINAMEN), _
ws.Cells(z, cWSD_SP_DATEINAMEN)).Sort _
Key1:=ws.Cells(cWSD_Z_ERSTEWERTEZEILE, cWSD_SP_DATEINAMEN), _
Order1:=xlAscending, _
Header:=xlNo
End If
->e2) doppelte löschen, alle nicht *.xls löschen
For x = z To cWSD_Z_ERSTEWERTEZEILE Step -1
If ws.Cells(x, cWSD_SP_DATEINAMEN).Value = ws.Cells(x - 1, cWSD_SP_DATEINAMEN).Value Then
->doppelten Dateinamen löschen
If x > cWSD_Z_ERSTEWERTEZEILE Then ws.Rows(x).Delete
Else
-><> *.xls-Dateinamen löschen
If LCase(Right(ws.Cells(x, cWSD_SP_DATEINAMEN).Value, Len(cWSD_DATEIENDUNGFILTER))) <> _
LCase(cWSD_DATEIENDUNGFILTER) Then
ws.Rows(x).Delete
End If
End If
Next
->f) Spalte optimale Breite
ws.Columns(cWSD_SP_DATEINAMEN).AutoFit
AUFRAEUMEN:
Set wb = Nothing: Set ws = Nothing
End Sub
'*************************************************************************************************
Sub LinksErsetzen_BlattLinksErzeugen()
'*** Legt eine Excel-Datei namens cWBNAME_LINKSERSETZEN im
'*** Pfad der Makro-Datei an, wenn noch nicht vorhanden
'***
'*** Setzt ein neues Blatt cWSL_NAME in diese Arbeitsmappe.
'*** Wenn solch ein Blatt bereits vorhanden ist, wird nur der Inhalt gelöscht.
'***
'*** Im weiteren erfolgt eine Dateiauswahl einer Datei per Datei-Auswahl-Dialog.
'*** Die in dieser Datei enthaltenen links werden in den Spalten links alt und links neu
'*** abgelegt.
'*** Im Nachhinein können die Zeilen, deren link nicht verändert werden sollen
'*** von Hand gelöscht werden.
'*** In der Spalte links neu müssen die links von Hand auf das neu Ziel geändert werden.
Dim wb As Workbook, ws As Worksheet, wbl As Workbook, wsl As Worksheet, h As Hyperlink
Dim sWBName As String, sWBPfad As String, sWSName As String
Dim vFile As Variant, z As Long, x As Long, sAddress As String
->a) prüfen, ob cWBNAME_LINKSERSETZEN existiert.
-> wenn nein, Datei anlegen
->a1) Datei exisitiert nicht -> anlegen
->a21) prüfen, ob Datei bereits geöffnet ist
->a22) Datei nicht offen -> öffnen
->a3) Blattnamen prüfen, ggf neu anlegen
->a4) Blattnamen vergeben
sWBPfad = ThisWorkbook.Path
sWBName = cWBNAME_LINKSERSETZEN
sWSName = cWSL_NAME
If Not DateiUndBlattAnlegen(wb, ws, sWBName, sWBPfad, sWSName) Then GoTo AUFRAEUMEN
->b) Formatieren als Text
ws.Cells.NumberFormat = @: ws.Cells.Font.Size = 8
->c) Überschriften
With ws.Cells(cWSL_Z_UEBSCHR, cWSL_SP_LINK_ALT)
.Value = cWSL_SP_LINK_ALT_TXT: .Font.Bold = True
End With
With ws.Cells(cWSL_Z_UEBSCHR, cWSL_SP_LINK_NEU)
.Value = cWSL_SP_LINK_NEU_TXT: .Font.Bold = True
End With
->d) Datei auswählen, deren Links aufgelistet werden sollen
z = cWSL_Z_ERSTEWERTEZEILE - 1
MsgBox _
Bitte wählen Sie mit dem nachfolgenden Datei-Dialog & vbLf & _
die Datei aus, deren links aufgelistet werden sollen.
vFile = Application.GetOpenFilename(MultiSelect:=False)
If vbBoolean = VarType(vFile) Then GoTo AUFRAEUMEN
->d1) Datei öffnen
On Error Resume Next
Set wbl = Workbooks.Open(FileName:=vFile)
If Err.Number <> 0 Then Err.Clear
On Error GoTo 0
If wbl Is Nothing Then
MsgBox Datei & vFile & konnte nicht geöffnet werden.
GoTo AUFRAEUMEN
End If
->d2) links auflisten
For Each wsl In wbl.Worksheets
x = wsl.Hyperlinks.Count
For Each h In wsl.Hyperlinks
z = z + 1
sAddress = h.Address
If Left(sAddress, Len(file://)) = file:// Then
sAddress = Right(sAddress, Len(sAddress) - Len(file://))
End If
ws.Cells(z, cWSL_SP_LINK_ALT).Value = sAddress
ws.Cells(z, cWSL_SP_LINK_NEU).Value = sAddress
Next
Next
->d3) Datei schliessen
wbl.Close savechanges:=False
->e) Nachbearbeitung
->e1) sortieren
If z > cWSL_Z_ERSTEWERTEZEILE Then
ws.Range(ws.Cells(cWSL_Z_ERSTEWERTEZEILE, cWSL_SP_LINK_ALT), _
ws.Cells(z, cWSL_SP_LINK_NEU)).Sort _
Key1:=ws.Cells(cWSL_Z_ERSTEWERTEZEILE, cWSL_SP_LINK_ALT), _
Order1:=xlAscending, _
Header:=xlNo
End If
->e2) doppelte löschen, alle nicht *.xls löschen
For x = z To cWSL_Z_ERSTEWERTEZEILE + 1 Step -1
If ws.Cells(x, cWSL_SP_LINK_ALT).Value = ws.Cells(x - 1, cWSL_SP_LINK_ALT).Value Then
->doppelten links löschen
ws.Rows(x).Delete
End If
Next
->f) Spalten optimale Breite
ws.Columns(cWSL_SP_LINK_ALT).AutoFit
ws.Columns(cWSL_SP_LINK_NEU).AutoFit
ActiveWindow.Zoom = 75
AUFRAEUMEN:
Set wb = Nothing: Set ws = Nothing
Set wbl = Nothing: Set wsl = Nothing: Set h = Nothing
End Sub
'*************************************************************************************************
Private Function DateiUndBlattAnlegen(wb As Workbook, ws As Worksheet, _
sWBName As String, sWBPfad As String, sWSName As String) As Boolean
->a) prüfen, ob cWBNAME_LINKSERSETZEN existiert.
-> wenn nein, Datei anlegen
->a1) Datei exisitiert nicht -> anlegen
->a21) prüfen, ob Datei bereits geöffnet ist
->a22) Datei nicht offen -> öffnen
->a3) Blattnamen vergeben
If Dir(sWBPfad & Application.PathSeparator & sWBName) = Then
->a1) Datei exisitiert nicht -> anlegen
Set wb = Workbooks.Add
wb.SaveAs FileName:=sWBPfad & Application.PathSeparator & sWBName
Else
->Datei existiert
->a21) prüfen, ob Datei bereits geöffnet ist
On Error Resume Next
Set wb = Workbooks(sWBName)
If Err.Number <> 0 Then Err.Clear
If wb Is Nothing Then
->a22) Datei nicht offen -> öffnen
Set wb = Workbooks.Open(FileName:=sWBPfad & Application.PathSeparator & sWBName)
If Err.Number <> 0 Then Err.Clear
If wb Is Nothing Then
MsgBox Datei & cWBNAME_LINKSERSETZEN & konnte nicht angelegt/geöffnet werden.
DateiUndBlattAnlegen = False
Exit Function
End If
End If
On Error GoTo 0
End If
->a3) Blatt prüfen
On Error Resume Next
Set ws = wb.Worksheets(sWSName)
If Err.Number <> 0 Then Err.Clear
If ws Is Nothing Then
Set ws = wb.Worksheets.Add(before:=wb.Worksheets(1))
Else
Set ws = wb.Worksheets.Add(before:=wb.Worksheets(1))
Application.DisplayAlerts = False
wb.Worksheets(sWSName).Delete
Application.DisplayAlerts = True
End If
->a4) Blattnamen vergeben
ws.Name = sWSName
DateiUndBlattAnlegen = True
End Function
'*************************************************************************************************
Private Function DateiOeffnenBlaetterSetzen(wb As Workbook, wsd As Worksheet, wsl As Worksheet, _
sWBName As String, sWBPfad As String, _
sWSNameDatei As String, sWSNameLinks As String) As Boolean
->a) Datei cWBNAME_LINKSERSETZEN öffnen.
->a1) Blatt cWSD_NAME setzen (Dateien-Blatt)
->a2) Blatt cWSL_NAME setzen (Link-Blatt)
DateiOeffnenBlaetterSetzen = False
If Dir(sWBPfad & Application.PathSeparator & sWBName) = Then
MsgBox Datei & sWBPfad & Application.PathSeparator & sWBName & nicht vorhanden.
Exit Function
End If
On Error Resume Next
Set wb = Workbooks(sWBName)
If Err.Number <> 0 Then Err.Clear
If wb Is Nothing Then
Set wb = Workbooks.Open(FileName:=sWBPfad & Application.PathSeparator & sWBName)
If Err.Number <> 0 Then Err.Clear
If wb Is Nothing Then
MsgBox Datei & sWBPfad & Application.PathSeparator & sWBName & konnte nicht geöffnet werden.
Exit Function
End If
End If
On Error GoTo 0
On Error Resume Next
Set wsd = wb.Worksheets(sWSNameDatei)
If Err.Number <> 0 Then Err.Clear
If wsd Is Nothing Then MsgBox Blatt & sWSNameDatei & nicht vorhanden.: Exit Function
On Error GoTo 0
On Error Resume Next
Set wsl = wb.Worksheets(sWSNameLinks)
If Err.Number <> 0 Then Err.Clear
If wsl Is Nothing Then MsgBox Blatt & sWSNameLinks & nicht vorhanden.: Exit Function
On Error GoTo 0
DateiOeffnenBlaetterSetzen = True
End Function
