Option Explicit
'----< SETUP >----
Const °Pfad_Alt =
"C:\Demo_Pfad_ALT"
Const
°Pfad_Neu = "D:\NEUER_PFAD"
'----</
SETUP >----
Public Sub
fx_Pfade_austauschen()
'----------------<
fx_Pfade_austauschen() >----------------
'< get_Paths >
'='C:\Users\poppr\Desktop\Excel\Excel\20190214_Pfade_aendern\[Excel_mit_Wert_A_inC3.xlsx]Sheet1'!B$2
Dim sPfad_Alt As String
sPfad_Alt = °Pfad_Alt
sPfad_Alt = LCase(sPfad_Alt)
Dim sPfad_Neu As String
sPfad_Neu = °Pfad_Neu
sPfad_Neu = LCase(sPfad_Neu)
'</ get_Paths >
'< get_Document >
Application.StatusBar = Now & " start Pfade
austauschen von " & sPfad_Alt & " -> " &
sPfad_Neu
Dim wb As Workbook
Set wb = ActiveWorkbook
'</ get_Document >
'------< Change_LinkSources >------
'*LinkSources sind echte externe
Verknuepfungen in Objekten oder externen Formelbezuegen
On Error Resume Next '*if no
ole objects or excelLinks exits
Application.DisplayAlerts = False '*dialog bei Link-wechsel unterdruecken
'----< @Loop: LinkSources >----
'*embedded grafiken und excel objekte
Dim sLink As Variant
For Each sLink In wb.LinkSources(1)
'----< IsLinkSource >----
sLink = LCase(sLink)
Debug.Print sLink
Application.StatusBar = "check
" & sLink
If sLink Like "*" &
sPfad_Alt & "*" Then
'---< Contains_Path >---
'< replace >
Dim sLink_neu As String
sLink_neu = Replace(sLink,
sPfad_Alt, sPfad_Neu, , , vbTextCompare)
'</ replace >
'< change_linksource >
Application.StatusBar =
"replace " & sLink
wb.ChangeLink sLink, sLink_neu, xlLinkTypeExcelLinks
wb.ChangeLink sLink, sLink_neu,
xlLinkTypeOLELinks
'</ change_linksource >
'---</ Contains_Path >---
End If
'----</ IsLinkSource >----
Next
'----</ @Loop: LinkSources >----
Application.DisplayAlerts = True
On Error GoTo 0
'------</
Change_LinkSources >------
'------< Change_Cells >------
'*.Range.Find
( Suchbegriff, Startposition, xlFindLookIn, LookAt, SearchOrder,
SearchDirection, MatchCase, MatchByte, SearchFormat )
'*xlFindLookIn: XlFormulas, XlValuesoder , XlNotes.
'*XlLookAt -Konstanten sein: XlWhole oder XlPart.
'*XlSearchOrder -Konstanten sein:
XlByRows oder XlByColumns.
'*MatchCase Optional
Variant True, um die Suche Groß-/Kleinschreibung. Der Standardwert ist False.
' oder Match
'=ADDRESS(MATCH(" Excel*",$A$1:$A$100,0),1)
'----< @Loop: Worksheets >----
Dim ws As Worksheet
For Each ws In wb.Worksheets
Dim usedRange As Range
Set usedRange = ws.usedRange
Dim cell As Range
Dim sValue_Alt As String
Dim sValue_Neu As String
Dim sText As String
'--< Change_Values >--
Set cell =
usedRange.Find(What:=sPfad_Alt, LookIn:=XlFindLookIn.xlValues,
LookAt:=XlLookAt.xlPart, MatchCase:=False, SearchOrder:=xlByRows)
If Not cell Is Nothing Then
Do
sValue_Alt = cell.Value
sValue_Alt =
LCase(sValue_Alt)
Application.StatusBar =
"cell." & cell.Address ' & " : " & sValue_Alt
Debug.Print "cell."
& cell.Address & " " & sValue_Alt
DoEvents
'< aendern >
sValue_Neu = Replace(sValue_Alt,
sPfad_Alt, sPfad_Neu, , , vbTextCompare)
cell.Value = sValue_Neu
'</ aendern >
Set cell = usedRange.FindNext()
Loop While Not cell Is Nothing
End If
'--</ Change_Values >--
'--< Change_Formulas >--
Set cell =
usedRange.Find(What:=sPfad_Alt, LookIn:=XlFindLookIn.xlFormulas,
LookAt:=XlLookAt.xlPart, MatchCase:=False, SearchOrder:=xlByRows)
If Not cell Is Nothing Then
Do
sValue_Alt = cell.Formula
sValue_Alt =
LCase(sValue_Alt)
Application.StatusBar =
"cell." & cell.Address & " " & sValue_Alt
Debug.Print "cell." &
cell.Address & " " & sValue_Alt
DoEvents
'< aendern >
sValue_Neu =
Replace(sValue_Alt, sPfad_Alt, sPfad_Neu, , , vbTextCompare)
cell.Formula = sValue_Neu
'</ aendern >
Set cell =
usedRange.FindNext()
Loop While Not cell Is Nothing
End If
'--</ Change_Formulas >--
'--< Change_Comments >--
'*find returns cell as range
Set cell =
usedRange.Find(What:=sPfad_Alt, LookIn:=XlFindLookIn.xlComments,
LookAt:=XlLookAt.xlPart, MatchCase:=False, SearchOrder:=xlByRows)
If Not cell Is Nothing Then
Do
sValue_Alt =
cell.Comment.Text
sValue_Alt =
LCase(sValue_Alt)
Application.StatusBar =
"cell." & cell.Address & " " & sValue_Alt
Debug.Print "cell."
& cell.Address & " " & sValue_Alt
DoEvents
'< aendern >
sValue_Neu =
Replace(sValue_Alt, sPfad_Alt, sPfad_Neu, , , vbTextCompare)
cell.Comment.Delete
cell.AddComment sValue_Neu
'</ aendern >
Set cell =
usedRange.FindNext()
Loop While Not cell Is Nothing
End If
'--</ Change_Comments >--
Next
'----</ @Loop: Worksheets >----
'------< Names_Variablen >------
Application.StatusBar = "Korrigiere Namensvariablen.."
'Loop durch Links
Dim Names_Variable As Name
For Each Names_Variable In wb.Names
'Namen prüfen
Dim sNames_Pfad As String
sNames_Pfad = Names_Variable.RefersToLocal
sNames_Pfad = LCase(sNames_Pfad)
If InStr(1, sNames_Pfad, sPfad_Alt,
vbTextCompare) >= 0 Then
sNames_Pfad =
Replace(sNames_Pfad, sPfad_Alt, sPfad_Neu, , , vbTextCompare)
End If
Next
'------< Names_Variablen >------
'------</ Change_Cells >------
'< Abschluss >
On Error GoTo 0
Application.StatusBar = Now & " Fertig."
MsgBox "Fertig"
'</ Abschluss >
'----------------</ fx_Pfade_austauschen()
>----------------
End Sub
|