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 vba Code zum Tauschen von Excel Pfaden in Verknüpfungen

14.02.2019 (👁11655)

Excel vba Addin-Code zum Tauschen von Excel Pfaden in Verknüpfungen


Das folgende vba Makro tauscht alle Verknüpfungen in einer Excel Datei zu einem neuen Pfad.

Dabei ist das makro zusätzlich als Excel Addin geschrieben, wodurch man die Datei einfach öffnen muss und die Datei dann als Menü->Addin->addin zur Verfügung steht in jeder Excel Datei

Vba Makro Code

Folgend der reine vba Makro Code zum Tauschen der Excel Links.

Dabei werden in diesem Fall direkt die Excel LinkSources geändert.

In Excel sind Workbook.LinkSources direkt  die internen Verknüpfungen, welche von Zellen oder Names-Bezügen und auch von Graphiken und eingebetteten OLE Objekten aus gehen.

Vba Code in Excel

Vba Macro Code

Option Explicit

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 = "C:\Users\poppr\Desktop\Excel\Excel\20190214_Pfade_aendern\Excel_mit_Wert_A_inC3.xlsx"

    sPfad_Alt = LCase(sPfad_Alt)

   

    Dim sPfad_Neu As String

    sPfad_Neu = "C:\Users\poppr\Desktop\Excel\Excel\20190214_Pfade_aendern\Excel_mit_Wert_B_inC3.xlsx"

    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 >

 

    On Error Resume Next    '*if no ole objects or excelLinks exits

           

    '----< @Loop: External_Links >----

    Dim sLink As Variant

    For Each sLink In wb.LinkSources(1)

        '----< IsLinkSource >----

        sLink = LCase(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 >

            wb.ChangeLink sLink, sLink_neu, xlLinkTypeExcelLinks

            wb.ChangeLink sLink, sLink_neu, xlLinkTypeOLELinks

            '</ change_linksource >

            '---</ Contains_Path >---

        End If

        '----</ IsLinkSource >----

    Next

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

   

    '< Abschluss >

    On Error GoTo 0

    Application.StatusBar = Now & " Fertig."

    MsgBox "Fertig"

    '</ Abschluss >

    '----------------</ fx_Pfade_austauschen() >----------------

End Sub

Addin-Code

Folgend der addin-code (klassisches Addin in der xlam datei

Der klassische Addin-Code ist deshalb Sinnvoll, weil man keine Exe ausführen kann.

Addin in klassischem  vba Addin

Option Explicit

Option Compare Text

 

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

'=====================================< Variablen >=====================================

Const °AddinName As String = "Addin_Pfade_anpassen_20190214_1449"

'=====================================</ 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 >=====================================