Readdy Write  
0,00 €
Your View Money
Views: Count
Self 20% 0
Your Content 60% 0

Users by Links 0
u1*(Content+Views) 10% 0
Follow-Follower 0
s2*(Income) 5% 0

Count
Followers 0
Login Register as User

Excel Addin: Ändern aller Pfade zu einem Neuen Pfad

21.02.2019 (👁14071)


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