Die beigefügt Excel Daten macht folgendes:
Das Excel Addin durchläuft das aktuelle Excel-Datei in allen Blättern und prüft ob ein alter Pfad vorhanden ist und wechselt alle Vorkommen zu einem neuen Laufwerk oder Pfad aus.
Das Excel Addin ist als Excel-Addin.xlam Datei beigefügt.
Man installiert das Excel Addin unter Excel->Entwicklertools->Addin->Auswählen:Addin_Pfade_aendern.xlam
Berücksichtigt werden :
Alte Pfad-Angaben in Zellen als Text, als Hyperlink, als Kommentar und auch zu eingebetteten Grafiken und Excel Objekten oder anderen extern OLE Objekten
Starten, Ausführen:
Zum Ausführen des vba Codes wählt man den Menüpunkt: Menüleiste->ADD-INS->Addin_Pfade_anpassen->Pfade austauschen
Dann werden alle Vorkommen in der Excel-Datei umgewandelt.
Addin einbinden
Man bindet das klassische Excel-Addin einfach ein, indem man die Datei auswählt in Excel->Menü->Entwicklertools->Add-Ins->Durchsuchen:->Addin_Pfade_aendern.xlam auswählen.
Danach ist das Addin unter dem Menü->Ribbon->ADD-INS vorhanden
Dateien zum Download:
Es sind 2 Dateien im Download.
1: die Excel-Addin Datei
2: eine Excel Test Datei
Excel Addin Inhalt:
Die beigefügte Excel Datei enthält folgende vba Code in der Addin-Datei selbst (Project->DieseArbeitsmappe)
Addin-Code
Das Addin selbst in der Datei
vbaProject(Addin_Pfade_aendern.xlam)->Microsoft Excel Objekte->DieseArbeitsmappe
Option Explicit Option Compare Text
'************************************************************** '=====================================< Variablen >===================================== Const °AddinName As String = "Addin_Pfade_anpassen" '=====================================</ Variablen >=====================================
'=====================================< Workbook >===================================== Private Sub Workbook_AddinInstall() '---------------------------------< Workbook_AddinInstall() >--------------------------------- Dim mBar As CommandBar Set mBar = Application.CommandBars(1) On Error Resume Next
Dim mMenu As CommandBarControl Dim v v = Application.CommandBars.FindControl(msoControlPopup, Application.CommandBars(1).Controls(°AddinName).ID)
If Err.Number > 0 Then Set mMenu = mBar.Controls.Add(msoControlPopup, , , 9, False) mMenu.Caption = °AddinName mMenu.TooltipText = °AddinName Else Set mMenu = Application.CommandBars.FindControl(msoControlPopup, Application.CommandBars(1).Controls(°AddinName).ID) End If
Dim vModul As String vModul = "" 'sAddinName & ".DieseArbeitsmappe."
'--------------------< Menuepunkte eintragen >--------------------
'------------< Untermenue : Hauptebene >------------ Dim ctrl1 As CommandBarButton Dim mSubMenu As CommandBarControl
'------------< 1 >------------ Set ctrl1 = mMenu.Controls.Add ctrl1.Caption = "Pfade austauschen" 'ctrl1.Tag = "fxProtect" 'ctrl1.TooltipText = "INI aus, schuetzen, Pos1" ctrl1.OnAction = vModul & "fx_Pfade_austauschen" ctrl1.FaceId = 893 ctrl1.Style = msoButtonIconAndCaption ctrl1.BeginGroup = True '------------</ 1 >------------
'---------------------------------</ Workbook_AddinInstall() >--------------------------------- End Sub
Sub Workbook_AddinUninstall() '---------------------------------< Workbook_AddinUninstall() >--------------------------------- Dim mMenu On Error Resume Next Set mMenu = Application.CommandBars.FindControl(msoControlPopup, Application.CommandBars(1).Controls(°AddinName).ID) mMenu.Delete '---------------------------------</ Workbook_AddinUninstall() >--------------------------------- End Sub
'=====================================</ Workbook >=====================================
|
Excel Modul:
mdlPfade_aendern
im VBAProject->(Addin_Pfade_aendern.xlam)->Module->mdlPfade_aendern
'----< 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 >----
'------</ Change_Cells >------
'< Abschluss > On Error GoTo 0 Application.StatusBar = Now & " Fertig." MsgBox "Fertig" '</ Abschluss > '----------------</ fx_Pfade_austauschen() >---------------- End Sub
|