Excel links ersetzen

Dieses Thema Excel links ersetzen im Forum "Microsoft Office Suite" wurde erstellt von MechMex, 12. Sep. 2006.

Thema: Excel links ersetzen hallo zusammen! gibt es ein eine möglichkeit in mehreren excel datein einen link zu suchen und diesen ersetzen zu...

  1. hallo zusammen!

    gibt es ein eine möglichkeit in mehreren excel datein einen link zu suchen
    und diesen ersetzen zu lassen?
    d.h in ca. 30 excel dateien ist dieser link uns soll dann auf ein anderes dokument
    am server verweisen.

    danke im voraus
    lg Mex
     
  2. Hi

    Darf ich noch kurz fragen ob dieser Link pro Datei in jedem Tabellenblatt gesucht werden muss oder gibts in der Datei nur jeweils ein Tabellenblatt?

    mfg billy
     
  3. hallo!

    voraussichtlich sind die links am ersten blatt.
    alle excel datein haben min. 2 blätter.

    lg Mex
     
  4. Hat der Link auch eine SubAddress, also einen zusätzlichen Verweis auf Zellen ?

    Gruß Matjes :)
     
  5. hallo!

    nein! der link verweist auf eine datei am server.

    lg Mex
     
  6. Dann gibts heute abend ein Werkzeug dafür  ;)

    Gruß Matjes :)
     
  7. Gebrauchshinweis:

    Es soll in mehreren Dateien ein/mehrere Links ersetz werden.
    In der Datei STEUERDATEI_LINKSERSETZEN.xls sind diese Daten zu beschreiben.

    Die STEUERDATEI_LINKSERSETZEN.xls hat 2 Blätter:

      - Blatt DATEIEN enthält in der ersten Spalte ab Zeile 2 die
        Dateinamen mit vollständigem Pfad

      - Blatt Zu bearbeitende links enthält in der ersten Spalte ab Zeile 2
        die links, die bearbeitet werden sollen, und in der 2. Spalte die
        entsprechenden neuen links, die die alten ersetzen sollen.

    Die fertige STEUERDATEI_LINKSERSETZEN.xls wird durch den Makro LinksErsetzen() abgearbeitet. Der Makro erwartet die Datei im Pfad der Mappe, die den Makro enthält.



    1. Schwierigkeit:
    Wie bekommt man die vollständigen Dateinamen ohne Schreibfehler auf das Blatt DATEIEN?

    1. Lösung:
    Mit dem Makro LinksErsetzen_BlattDateienErzeugen() kann man die gewünschten Dateien auswählen. Das Makro erzeugt, wenn notwendig die Datei STEUERDATEI_LINKSERSETZEN.xls und das Blatt DATEIEN und schreibt die ausgewählten Dateien in die erste Spalte des Blattes ab Zeile 2.


    2. Schwierigkeit:
    Wie bekommt man die vollständigen links ohne Schreibfehler auf das Blatt Zu bearbeitende links?

    2. Lösung:
    Mit dem Makro LinksErsetzen_BlattLinksErzeugen() kann man alle links einer Datei auf das Blatt Zu bearbeitende links schreiben. Dazu kann man mit dem Makro diese Datei auswählen. Das Makro schreibt dann alle links dieser Datei aus das  latt Zu bearbeitende links, ab Zeile 2 sowohl in Spalte 1 als auch in Spalte 2.
    Hier ist eine Nachbearbeitung notwendig. Zuerst löscht man alle Zeilen mit links, die nicht ersetzt werden sollen. Dann verändert man die links in Spalte 2 so, wie sie ersetzt werden sollen.
    Soll z.B. Das Laufwerk geändert werden, ersetzt man per Suchen/ersetzen in allen Zeilen Laufwerksbuchstabe Alt:\ gegen Laufwerksbuchstabe Neu:\.

    Das Makro erzeugt, wenn notwendig die Datei STEUERDATEI_LINKSERSETZEN.xls und das Blatt Zu bearbeitende links.

    Wenn etwas beim erzeugen/ändern der links schief geht, wiederholt man die Prozedur 1. bzw. 2.


    Noch eins:
    Das Makro LinksErsetzen() legt keine Sicherung vor der Bearbeitung an. Das sollte man im eigenen Interesse dann vorher selbst tun :)

    Gruß Matjes :)

    ps: Der gesamte Code sollte in einer eigenen Mappe in einem Modul liegen.

    Code:
    Option Explicit
    
    Private Const cWBNAME_LINKSERSETZEN = STEUERDATEI_LINKSERSETZEN.xls
    'Blatt->zu bearbeitende Dateien'
    Private Const cWSD_NAME = DATEIEN
    Private Const cWSD_Z_UEBSCHR = 1
    Private Const cWSD_Z_ERSTEWERTEZEILE = cWSD_Z_UEBSCHR + 1
    Private Const cWSD_SP_DATEINAMEN = 1
    Private Const cWSD_SP_DATEINAMEN_TXT = zu bearbeitende Dateien
    Private Const cWSD_DATEIENDUNGFILTER = .xls
    'Blatt->zu bearbeitende Links'
    Private Const cWSL_NAME = Zu bearbeitende links
    Private Const cWSL_Z_UEBSCHR = 1
    Private Const cWSL_Z_ERSTEWERTEZEILE = cWSL_Z_UEBSCHR + 1
    Private Const cWSL_SP_LINK_ALT = 1
    Private Const cWSL_SP_LINK_ALT_TXT = links alt
    Private Const cWSL_SP_LINK_NEU = cWSL_SP_LINK_ALT + 1
    Private Const cWSL_SP_LINK_NEU_TXT = links neu
    
    '*************************************************************************************************
    Sub LinksErsetzen()
    '*** Erwartet eine Excel-Datei namens cWBNAME_LINKSERSETZEN im
    '*** Pfad der Makro-Datei
    '***
    '*** Blatt cWSD_NAME - zu bearbeitendde Dateien
    '*** und
    '*** Blatt cWSD_NAME - zu bearbeitende/ersetzende links
    '*** müssen vorhanden sein.
    '***
    '*** In allen zu bearbeitenden Dateien werden die links alt gesucht und durch den
    '*** entsprechenden link neu ersetzt.
    '***
    
      Dim wb As Workbook, wb2 As Workbook, wsl As Worksheet, wsd As Worksheet, ws2 As Worksheet, h As Hyperlink
      Dim sWBName As String, sWBPfad As String, sWSNameDatei As String, sWSNameLinks As String
      Dim sFile As Variant, slink As String, z As Long, x As Long, sAddress As String
    
     ->a)   Datei cWBNAME_LINKSERSETZEN öffnen.
     ->a1)  Blatt cWSD_NAME setzen (Dateien-Blatt)
     ->a2)  Blatt cWSL_NAME setzen (Link-Blatt)
      sWBPfad = ThisWorkbook.Path
      sWBName = cWBNAME_LINKSERSETZEN
      sWSNameDatei = cWSD_NAME
      sWSNameLinks = cWSL_NAME
      If Not DateiOeffnenBlaetterSetzen(wb, wsd, wsl, _
                                        sWBName, sWBPfad, _
                                        sWSNameDatei, sWSNameLinks) Then GoTo AUFRAEUMEN
      
      
     ->alle Dateien
      z = cWSD_Z_ERSTEWERTEZEILE - 1
      Do
        z = z + 1
        sFile = wsd.Cells(z, cWSD_SP_DATEINAMEN).Value
        If sFile =  Then Exit Do
        On Error Resume Next
        Set wb2 = Workbooks.Open(FileName:=sFile)
        If Err.Number <> 0 Then Err.Clear
        On Error GoTo 0
        If wb2 Is Nothing Then
          MsgBox Datei  & sFile &  konnte nicht geöffnet werden.
          GoTo AUFRAEUMEN
        End If
        For Each ws2 In wb2.Worksheets
          For Each h In ws2.Hyperlinks
            x = cWSL_Z_ERSTEWERTEZEILE - 1
            Do
              x = x + 1
              slink = wsl.Cells(x, cWSL_SP_LINK_ALT).Value
              If slink =  Then Exit Do
              sAddress = h.Address
              If Left(sAddress, Len(file://)) = file:// Then
                sAddress = Right(sAddress, Len(sAddress) - Len(file://))
              End If
              
              If slink = sAddress Then
                On Error Resume Next
                h.Address = wsl.Cells(x, cWSL_SP_LINK_NEU).Value
                If Err.Number <> 0 Then
                  Err.Clear
                  MsgBox _
                    Ziel für folgenden link nicht vorhanden: & vbLf & _
                    wsl.Cells(x, cWSL_SP_LINK_NEU).Value & vbLf & _
                    Datei:  & wb2.Name & vbLf & _
                    Blatt:  & ws2.Name & vbLf & _
                    Zelle:  & h.Range.Address(False, False)
                  On Error GoTo 0
                  GoTo AUFRAEUMEN
                End If
                On Error GoTo 0
              End If
            Loop
          Next
        Next
        wb2.Close savechanges:=True
      Loop
      
    AUFRAEUMEN:
      Set wb = Nothing: Set wb2 = Nothing: Set wsl = Nothing: Set wsd = Nothing: Set ws2 = Nothing: Set h = Nothing
    End Sub
    
    
    '*************************************************************************************************
    Sub LinksErsetzen_BlattDateienErzeugen()
    '*** Legt eine Excel-Datei namens cWBNAME_LINKSERSETZEN im
    '*** Pfad der Makro-Datei an, wenn noch nicht vorhanden
    '***
    '*** Setzt ein neues Blatt cWSD_NAME in diese Arbeitsmappe.
    '*** Wenn solch ein Blatt bereits vorhanden ist, wird nur der Inhalt gelöscht.
    '***
    '*** Im weiteren erfolgt eine Dateiauswahl (auch mehrfach) per Datei-Auswahl-Dialog.
    '*** Diese Dateien werden der Reihe nach in der ersten Spalte abgelegt.
    
      Dim wb As Workbook, ws As Worksheet
      Dim sWBName As String, sWBPfad As String, sWSName As String
      Dim vFile As Variant, z As Long, x As Long
    
     ->a)   prüfen, ob cWBNAME_LINKSERSETZEN existiert.
     ->     wenn nein, Datei anlegen
     ->a1)  Datei exisitiert nicht -> anlegen
     ->a21) prüfen, ob Datei bereits geöffnet ist
     ->a22) Datei nicht offen -> öffnen
     ->a3)  Blattnamen prüfen, ggf neu anlegen
     ->a4)  Blattnamen vergeben
      sWBPfad = ThisWorkbook.Path
      sWBName = cWBNAME_LINKSERSETZEN
      sWSName = cWSD_NAME
      If Not DateiUndBlattAnlegen(wb, ws, sWBName, sWBPfad, sWSName) Then GoTo AUFRAEUMEN
      
     ->b) Formatieren als Text
      ws.Cells.NumberFormat = @
     ->c) Überschrift
      With ws.Cells(cWSD_Z_UEBSCHR, cWSD_SP_DATEINAMEN)
        .Value = cWSD_SP_DATEINAMEN_TXT: .Font.Bold = True
      End With
      
     ->d) Dateien auswählen und in Spalte cWSD_SP_DATEINAMEN schreiben
      z = cWSD_Z_ERSTEWERTEZEILE - 1
      MsgBox _
        Bitte wählen Sie mit dem nachfolgenden Datei-Dialog die zu bearbeitenden Dateien aus. & vbLf & _
        Mehrfachselektion ist möglich.
      Do
        vFile = Application.GetOpenFilename(MultiSelect:=True)
        If vbBoolean <> VarType(vFile) Then->bei Abbruch Boolean(False)
          For x = LBound(vFile) To UBound(vFile)
            z = z + 1
            ws.Cells(z, cWSD_SP_DATEINAMEN).Value = vFile(x)
          Next
        End If
        If vbNo = MsgBox(Wollen Sie weitere Dateien auswählen ?, _
                         vbQuestion + vbDefaultButton1 + vbYesNo) Then Exit Do
      Loop
      
     ->e) Nachbearbeitung
     ->e1) sortieren
      If z > cWSD_Z_ERSTEWERTEZEILE Then
        ws.Range(ws.Cells(cWSD_Z_ERSTEWERTEZEILE, cWSD_SP_DATEINAMEN), _
                 ws.Cells(z, cWSD_SP_DATEINAMEN)).Sort _
                 Key1:=ws.Cells(cWSD_Z_ERSTEWERTEZEILE, cWSD_SP_DATEINAMEN), _
                 Order1:=xlAscending, _
                 Header:=xlNo
      End If
     ->e2) doppelte löschen, alle nicht *.xls löschen
      For x = z To cWSD_Z_ERSTEWERTEZEILE Step -1
        If ws.Cells(x, cWSD_SP_DATEINAMEN).Value = ws.Cells(x - 1, cWSD_SP_DATEINAMEN).Value Then
         ->doppelten Dateinamen löschen
          If x > cWSD_Z_ERSTEWERTEZEILE Then ws.Rows(x).Delete
        Else
         -><> *.xls-Dateinamen löschen
          If LCase(Right(ws.Cells(x, cWSD_SP_DATEINAMEN).Value, Len(cWSD_DATEIENDUNGFILTER))) <> _
             LCase(cWSD_DATEIENDUNGFILTER) Then
            ws.Rows(x).Delete
          End If
        End If
      Next
      
     ->f) Spalte optimale Breite
      ws.Columns(cWSD_SP_DATEINAMEN).AutoFit
    AUFRAEUMEN:
      Set wb = Nothing: Set ws = Nothing
    End Sub
    
    '*************************************************************************************************
    Sub LinksErsetzen_BlattLinksErzeugen()
    '*** Legt eine Excel-Datei namens cWBNAME_LINKSERSETZEN im
    '*** Pfad der Makro-Datei an, wenn noch nicht vorhanden
    '***
    '*** Setzt ein neues Blatt cWSL_NAME in diese Arbeitsmappe.
    '*** Wenn solch ein Blatt bereits vorhanden ist, wird nur der Inhalt gelöscht.
    '***
    '*** Im weiteren erfolgt eine Dateiauswahl einer Datei per Datei-Auswahl-Dialog.
    '*** Die in dieser Datei enthaltenen links werden in den Spalten links alt und links neu
    '*** abgelegt.
    '*** Im Nachhinein können die Zeilen, deren link nicht verändert werden sollen
    '*** von Hand gelöscht werden.
    '*** In der Spalte links neu müssen die links von Hand auf das neu Ziel geändert werden.
    
    
      Dim wb As Workbook, ws As Worksheet, wbl As Workbook, wsl As Worksheet, h As Hyperlink
      Dim sWBName As String, sWBPfad As String, sWSName As String
      Dim vFile As Variant, z As Long, x As Long, sAddress As String
    
     ->a)   prüfen, ob cWBNAME_LINKSERSETZEN existiert.
     ->     wenn nein, Datei anlegen
     ->a1)  Datei exisitiert nicht -> anlegen
     ->a21) prüfen, ob Datei bereits geöffnet ist
     ->a22) Datei nicht offen -> öffnen
     ->a3)  Blattnamen prüfen, ggf neu anlegen
     ->a4)  Blattnamen vergeben
      sWBPfad = ThisWorkbook.Path
      sWBName = cWBNAME_LINKSERSETZEN
      sWSName = cWSL_NAME
      If Not DateiUndBlattAnlegen(wb, ws, sWBName, sWBPfad, sWSName) Then GoTo AUFRAEUMEN
      
     ->b) Formatieren als Text
      ws.Cells.NumberFormat = @: ws.Cells.Font.Size = 8
     ->c) Überschriften
      With ws.Cells(cWSL_Z_UEBSCHR, cWSL_SP_LINK_ALT)
        .Value = cWSL_SP_LINK_ALT_TXT: .Font.Bold = True
      End With
      With ws.Cells(cWSL_Z_UEBSCHR, cWSL_SP_LINK_NEU)
        .Value = cWSL_SP_LINK_NEU_TXT: .Font.Bold = True
      End With
      
     ->d) Datei auswählen, deren Links aufgelistet werden sollen
      z = cWSL_Z_ERSTEWERTEZEILE - 1
      MsgBox _
        Bitte wählen Sie mit dem nachfolgenden Datei-Dialog & vbLf & _
        die Datei aus, deren links aufgelistet werden sollen.
      vFile = Application.GetOpenFilename(MultiSelect:=False)
      If vbBoolean = VarType(vFile) Then GoTo AUFRAEUMEN
      
     ->d1) Datei öffnen
      On Error Resume Next
      Set wbl = Workbooks.Open(FileName:=vFile)
      If Err.Number <> 0 Then Err.Clear
      On Error GoTo 0
      If wbl Is Nothing Then
        MsgBox Datei  & vFile & konnte nicht geöffnet werden.
        GoTo AUFRAEUMEN
      End If
      
     ->d2) links auflisten
      For Each wsl In wbl.Worksheets
        x = wsl.Hyperlinks.Count
        For Each h In wsl.Hyperlinks
          z = z + 1
          sAddress = h.Address
          If Left(sAddress, Len(file://)) = file:// Then
            sAddress = Right(sAddress, Len(sAddress) - Len(file://))
          End If
    
          ws.Cells(z, cWSL_SP_LINK_ALT).Value = sAddress
          ws.Cells(z, cWSL_SP_LINK_NEU).Value = sAddress
        Next
      Next
      
     ->d3) Datei schliessen
      wbl.Close savechanges:=False
      
     ->e) Nachbearbeitung
     ->e1) sortieren
      If z > cWSL_Z_ERSTEWERTEZEILE Then
        ws.Range(ws.Cells(cWSL_Z_ERSTEWERTEZEILE, cWSL_SP_LINK_ALT), _
                 ws.Cells(z, cWSL_SP_LINK_NEU)).Sort _
                 Key1:=ws.Cells(cWSL_Z_ERSTEWERTEZEILE, cWSL_SP_LINK_ALT), _
                 Order1:=xlAscending, _
                 Header:=xlNo
      End If
     ->e2) doppelte löschen, alle nicht *.xls löschen
      For x = z To cWSL_Z_ERSTEWERTEZEILE + 1 Step -1
        If ws.Cells(x, cWSL_SP_LINK_ALT).Value = ws.Cells(x - 1, cWSL_SP_LINK_ALT).Value Then
         ->doppelten links löschen
          ws.Rows(x).Delete
        End If
      Next
      
     ->f) Spalten optimale Breite
      ws.Columns(cWSL_SP_LINK_ALT).AutoFit
      ws.Columns(cWSL_SP_LINK_NEU).AutoFit
      ActiveWindow.Zoom = 75
    AUFRAEUMEN:
      Set wb = Nothing: Set ws = Nothing
      Set wbl = Nothing: Set wsl = Nothing: Set h = Nothing
    End Sub
    
    '*************************************************************************************************
    Private Function DateiUndBlattAnlegen(wb As Workbook, ws As Worksheet, _
                                          sWBName As String, sWBPfad As String, sWSName As String) As Boolean
     ->a)   prüfen, ob cWBNAME_LINKSERSETZEN existiert.
     ->     wenn nein, Datei anlegen
     ->a1)  Datei exisitiert nicht -> anlegen
     ->a21) prüfen, ob Datei bereits geöffnet ist
     ->a22) Datei nicht offen -> öffnen
     ->a3)  Blattnamen vergeben
    
      If Dir(sWBPfad & Application.PathSeparator & sWBName) =  Then
       ->a1) Datei exisitiert nicht -> anlegen
        Set wb = Workbooks.Add
        wb.SaveAs FileName:=sWBPfad & Application.PathSeparator & sWBName
      Else
       ->Datei existiert
        
       ->a21) prüfen, ob Datei bereits geöffnet ist
        On Error Resume Next
        Set wb = Workbooks(sWBName)
        If Err.Number <> 0 Then Err.Clear
        If wb Is Nothing Then
         ->a22) Datei nicht offen -> öffnen
          Set wb = Workbooks.Open(FileName:=sWBPfad & Application.PathSeparator & sWBName)
          If Err.Number <> 0 Then Err.Clear
          If wb Is Nothing Then
            MsgBox Datei  & cWBNAME_LINKSERSETZEN &  konnte nicht angelegt/geöffnet werden.
            DateiUndBlattAnlegen = False
            Exit Function
          End If
        End If
        On Error GoTo 0
      End If
      
     ->a3) Blatt prüfen
      On Error Resume Next
      Set ws = wb.Worksheets(sWSName)
      If Err.Number <> 0 Then Err.Clear
      If ws Is Nothing Then
        Set ws = wb.Worksheets.Add(before:=wb.Worksheets(1))
      Else
        Set ws = wb.Worksheets.Add(before:=wb.Worksheets(1))
        Application.DisplayAlerts = False
        wb.Worksheets(sWSName).Delete
        Application.DisplayAlerts = True
      End If
     ->a4) Blattnamen vergeben
      ws.Name = sWSName
    
      DateiUndBlattAnlegen = True
    End Function
    
    '*************************************************************************************************
    Private Function DateiOeffnenBlaetterSetzen(wb As Workbook, wsd As Worksheet, wsl As Worksheet, _
                                                sWBName As String, sWBPfad As String, _
                                                sWSNameDatei As String, sWSNameLinks As String) As Boolean
     ->a)   Datei cWBNAME_LINKSERSETZEN öffnen.
     ->a1)  Blatt cWSD_NAME setzen (Dateien-Blatt)
     ->a2)  Blatt cWSL_NAME setzen (Link-Blatt)
      
      DateiOeffnenBlaetterSetzen = False
      
      If Dir(sWBPfad & Application.PathSeparator & sWBName) =  Then
        MsgBox Datei  & sWBPfad & Application.PathSeparator & sWBName &  nicht vorhanden.
        Exit Function
      End If
      On Error Resume Next
      Set wb = Workbooks(sWBName)
      If Err.Number <> 0 Then Err.Clear
      If wb Is Nothing Then
        Set wb = Workbooks.Open(FileName:=sWBPfad & Application.PathSeparator & sWBName)
        If Err.Number <> 0 Then Err.Clear
        If wb Is Nothing Then
          MsgBox Datei  & sWBPfad & Application.PathSeparator & sWBName &  konnte nicht geöffnet werden.
          Exit Function
        End If
      End If
      On Error GoTo 0
      
      On Error Resume Next
      Set wsd = wb.Worksheets(sWSNameDatei)
      If Err.Number <> 0 Then Err.Clear
      If wsd Is Nothing Then MsgBox Blatt  & sWSNameDatei &  nicht vorhanden.: Exit Function
      On Error GoTo 0
    
      On Error Resume Next
      Set wsl = wb.Worksheets(sWSNameLinks)
      If Err.Number <> 0 Then Err.Clear
      If wsl Is Nothing Then MsgBox Blatt  & sWSNameLinks &  nicht vorhanden.: Exit Function
      On Error GoTo 0
    
      DateiOeffnenBlaetterSetzen = True
    End Function
     
  8. hi matjes!

    oh man vielen dank für deine arbeit
    ich werde es baldmöglichst ausprobieren

    lg Mex
     
Die Seite wird geladen...

Excel links ersetzen - Ähnliche Themen

Forum Datum
excel 2003 hyperlinks unter excel 2007 Windows XP Forum 12. Apr. 2011
Aus Excel v2007 PDF mit "gültigen" Hyperlinks drucken Windows XP Forum 13. März 2008
Excel 2003 Hyperlinks funktionieren nicht immer Windows XP Forum 14. Feb. 2005
[Excel] Hyperlinks ändern Microsoft Office Suite 2. Dez. 2004
Wie kann man mehrere Hyperlinks in Excel auf einmal entfernen? Microsoft Office Suite 28. Okt. 2004