Excel Code für ein kleines Addin

Option Explicit

Option Compare Text

'**************************************************************

Const °AddinName As String = "Pfade_anpassen"

'*Installation Addin->Menubar

Sub Workbook_AddinInstall()

    Check_Addin_Menu

End Sub

Private Sub Workbook_Open()

    Check_Addin_Menu

End Sub

Sub Check_Addin_Menu()

    '----------------< Check_Addin_Menu() >----------------

    '--< Install_MenuBar >--

    'Dim addin_Commandbar As CommandBar

    Dim addin_Menu As CommandBarControl

    Set addin_Menu = find_AddinMenu(°AddinName)

    '< check >

    If Not addin_Menu Is Nothing Then

        addin_Menu.Visible = True

        Exit Sub

    End If

    '</ check >

    On Error GoTo 0

    '--< Install_MenuBar >--

    '< create new >

    Set addin_Menu = Application.CommandBars(1).Controls.Add(Type:=msoControlPopup, Temporary:=False)

    addin_Menu.Caption = °AddinName

    '</ create new >

    '< Menue_Punkte_einfuegen >

    commandBarButton_anfuegen addin_Menu, sText:="Pfade austauschen", sActionName:="fx_Pfade_austauschen", faceID:=893, beginGroup:=False

    '</ Menue_Punkte_einfuegen >

    '< anzeigen >

    addin_Menu.Visible = True

    '</ anzeigen >

    '----------------</ Check_Addin_Menu() >----------------

End Sub

Private Sub commandBarButton_anfuegen(ByRef subMenu As CommandBarControl, ByVal sText As String, ByVal sActionName As String, ByVal faceID As Integer, ByVal beginGroup As Boolean)

    '------------< commandBarButton_anfuegen >------------

    Dim control_Element As CommandBarButton

    Set control_Element = subMenu.Controls.Add

    control_Element.Caption = sText

    control_Element.OnAction = sActionName

    control_Element.faceID = faceID

    control_Element.Style = msoButtonIconAndCaption

    control_Element.beginGroup = beginGroup

    '------------</ commandBarButton_anfuegen >------------

End Sub

Sub Workbook_AddinUninstall()

    '----------------< Uninstall in PowerPoint ??() >---------------

    '--< find_commandbar >--

    Dim addin_Commandbar As CommandBarControl

    Set addin_Commandbar = find_AddinMenu(°AddinName)

    '< check >

    If Err.Number <> 0 Then Exit Sub

    If addin_Commandbar Is Nothing Then Exit Sub

    '</ check >

    '--</ find_commandbar >--

    addin_Commandbar.Delete

    '----------------</ Uninstall in PowerPoint ??() >---------------

End Sub

'=====================< Helper-Functions >==============

Public Function find_AddinMenu(ByVal sName As String) As CommandBarControl

    '-----------< find_Commandbar() >--------------

    Dim search_Commandbar As CommandBarControl

    '----< @Loop: all_Commandbars >----

    For Each search_Commandbar In Application.CommandBars(1).Controls

        If search_Commandbar.Caption = sName Then

            '< match_return >

            Set find_AddinMenu = search_Commandbar

            Exit Function 'not necessary

            '</ match_return >

        End If

    Next

    '----</ @Loop: all_Commandbars >----

    '< nomatch >

    Set find_AddinMenu = Nothing

    '</ nomatch >

    '-----------</ find_Commandbar() >--------------

End Function

'=====================</ Helper-Functions >==============

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