Hyperlinkpfad via Macro ändern

Anke · 1970-01-01T00:00:00+00:00

Habe folgendes Problem: Excel-Datei mit mehreren Arbeitsblättern. Innerhalb jedes Arbeitsblattes befinden sich ca. 500 Zeilen mit Daten, die jeweils via Hyperlink mit Bildern verknüpft sind. Die Hyperlinks haben auch alle eine eigene Bezeichnung. Da sich das Verzeichnis der Bilder geändert hat (Serverdefekt) muß ich jetzt alle Hyperlinks ändern (ca. 1000). Ich habe zwar im Internet ein Macro gefunden, was auch funktioniert, allerdings ist hier dann die Bezeichnung der Hyperlinks weg. Die sollte aber erhalten bleiben. Die Exceldatei umwandeln in eine Html-Datei und dort die Hyperlinks via suchen/ersetzen tauschen und die Datei anschließend in Excel öffnen und abspeichern scheidet als Lösung aus, da ich ein "vorgelagertes" Archivierungsprogramm nutzen muß und nicht an den eigentlichen Speicherort der Dateien gelangen kann. Ich kann also schon von vornherein die speichern/unter Website nicht durchführen. Wäre jetzt zu umständlich das zu erklären. Es kommt also nur eine Makrolösung in Frage. Kann mir jemand helfen?

Hallo Anke,
hier ein Code der aendert Adresse fuer alle Hyperlinks, die mit "jpg" beendet sind in gesamtem Workbook.
Nicht vergessen:
Vor dem Makro Start solltest Du von Deiner Datei eine Back-Up Kopie machen!!! :-).
Mfg, dan, cz.
Option Explicit
' Private Const ALTER_PFAD As String = "C:\server1\Digitalbilder"
Private Const NEUER_PFAD As String = "G:\test7\Digitalbilder\"
Private Const HYPERLINK_TARGET_TYPE As String = "JPG"

Public Sub Main(): On Error GoTo Err_Main
ReplaceAllHyperlinkAddress
Exit Sub
Err_Main:
MsgBox Err.Description, vbCritical, "Error"
End Sub

Private Sub ReplaceAllHyperlinkAddress()
Dim oneSheet As Worksheet
Dim oneCell As Range
Dim oneHyperlink As Hyperlink
Dim hyperlinksCount As Long
Dim replaceCount As Long
Dim notRepacedAddresses As String: notRepacedAddresses = "Not replaced: " & vbCrLf
Dim fileName As String
For Each oneSheet In ThisWorkbook.Worksheets
For Each oneCell In oneSheet.UsedRange.Cells
For Each oneHyperlink In oneCell.Hyperlinks
hyperlinksCount = hyperlinksCount + 1
If (Strings.InStr(Strings.UCase(oneHyperlink.Address), HYPERLINK_TARGET_TYPE) > 0) Then
fileName = GetFileNameFromHyperlinkAddress(oneHyperlink.Address)
If (fileName  "") Then
oneHyperlink.Address = NEUER_PFAD & fileName
replaceCount = replaceCount + 1
End If
Else
notRepacedAddresses = notRepacedAddresses & oneSheet.Name & ":" & oneHyperlink.Range. _
Address & ", " & oneHyperlink.Address & vbCrLf
End If
Next oneHyperlink
Next oneCell
Next oneSheet
If (hyperlinksCount - replaceCount > 0) Then MsgBox notRepacedAddresses, vbExclamation, " _
Caution, not all hyperlinks replaced"
End Sub

Private Function GetFileNameFromHyperlinkAddress(ByVal hyperlinkAddress As String):  _
GetFileNameFromHyperlinkAddress = ""
Dim fileNameSeparatorPosition As Integer: fileNameSeparatorPosition = Strings.InStrRev( _
hyperlinkAddress, "/")
If (fileNameSeparatorPosition  0) Then GetFileNameFromHyperlinkAddress = Strings.Right( _
hyperlinkAddress, Strings.Len(hyperlinkAddress) - fileNameSeparatorPosition)
End Function

Hallo Anke,
hast Du den Code komplett kopiert? Ich schicke den Code noch einmal. Kopiere es vom Text ' # Start # bis zu Text ' # End #.
Es soll dann so aussehen im VBA Editor:
Userbild

Wenn Du den Code in Editor (Module) kopiert hast, dann postiere den Cursor in die 'Sub Main' und druecke F5. Kommt immer noch der selbe Fehler?
Marko Code:
' # Start #
Option Explicit
' Private Const ALTER_PFAD As String = "C:\server1\Digitalbilder"
Private Const NEUER_PFAD As String = "G:\test7\Digitalbilder\"
Private Const HYPERLINK_TARGET_TYPE As String = "JPG"

Public Sub Main(): On Error GoTo Err_Main
ReplaceAllHyperlinkAddress
Exit Sub
Err_Main:
MsgBox Err.Description, vbCritical, "Error"
End Sub

Private Sub ReplaceAllHyperlinkAddress()
Dim oneSheet As Worksheet
Dim oneCell As Range
Dim oneHyperlink As Hyperlink
Dim hyperlinksCount As Long
Dim replaceCount As Long
Dim notRepacedAddresses As String: notRepacedAddresses = "Not replaced: " & vbCrLf
Dim fileName As String
Dim endPart As String
For Each oneSheet In ThisWorkbook.Worksheets
For Each oneCell In oneSheet.UsedRange.Cells
For Each oneHyperlink In oneCell.Hyperlinks
hyperlinksCount = hyperlinksCount + 1
endPart = Strings.Right(Strings.UCase(oneHyperlink.Address), Strings.Len( _
HYPERLINK_TARGET_TYPE))
If (endPart = HYPERLINK_TARGET_TYPE) Then
fileName = GetFileNameFromHyperlinkAddress(oneHyperlink.Address)
If (fileName  "") Then
oneHyperlink.Address = NEUER_PFAD & fileName
replaceCount = replaceCount + 1
End If
Else
notRepacedAddresses = notRepacedAddresses & oneSheet.Name & ":" & oneHyperlink.Range. _
Address & ", " & oneHyperlink.Address & vbCrLf
End If
Next oneHyperlink
Next oneCell
Next oneSheet
If (hyperlinksCount - replaceCount > 0) Then MsgBox notRepacedAddresses, vbExclamation, " _
Caution, not all hyperlinks replaced"
End Sub

Private Function GetFileNameFromHyperlinkAddress(ByVal hyperlinkAddress As String):  _
GetFileNameFromHyperlinkAddress = ""
Dim fileNameSeparatorPosition As Integer: fileNameSeparatorPosition = Strings.InStrRev( _
hyperlinkAddress, "/")
If (fileNameSeparatorPosition  0) Then GetFileNameFromHyperlinkAddress = Strings.Right( _
hyperlinkAddress, Strings.Len(hyperlinkAddress) - fileNameSeparatorPosition)
End Function

' # End #

Forumthread: Hyperlinkpfad via Macro ändern

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Infobox / Tutorial

Hyperlinkpfad in Excel via Macro ändern

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)