Verknüpfungen deaktivieren

[GERHARD44]

Hallo!
Ich habe folgendes Problem: Eine Excel-Datei ist mit vielen anderen Excel-Datein verknüpft. Es handelt sich um eine Personaleinteilungs-datei. Hier werden von Mitarbeitern mögliche Einteilungen für die Erstellung eines Dienstplans verknüpft. Diese Datei wird jeden Monat neu erstellt - so ändern sich die Monatstage und die Einteilungswünsche und Möglichkeiten der Mitarbeiter. Bei der Umstellung auf ein neues Monat werden alle Daten für das neue Monat im alten Monat überschrieben, weil verknüpft. Ich habe schon in der Excel-Datei unter "Datei/Verknüpfungen bearbeiten" die Verknüpfungen gelöscht. Aber irgendwie funktioniert das nicht. Gibt es eine Möglichkeit die Verknüpfungen einfach und sicher zu deaktivieren, damit die Datei mit den Daten des Vormonats nicht durch die Daten des aktuellen Monats ersetzt werden? 
Vielen Dank!

[Glausius]

Hallo,
die komplette Datei markieren, kopieren und dann an gleicher Stelle wieder einfügen, aber nicht alles, sonder nur die Werte.
Dann sind alle Formeln, Verknüpfungen und Bezüge weg.

[Gast 123]

Halla

mit diesem Programm von Hajo kann man alle Verknüpfungen in einer Datei gezielt auflisten. Man sieht jede einzelne Zelle!

mfg  Gast 123

Code:

Option Explicit       'Verknüpfung Hajo

Sub Verknuepfte_Zellen()
'**************************************************
'* H. Ziplies                                     *
'* 24.08.08                                       *
'* erstellt von HajoZiplies@web.de                *
'* http://Hajo-Excel.de/                          *
'**************************************************
   On Error GoTo Fehler1                           ' Fehlerbehandlung ausschalten
   Dim RaZelle As Range                            ' Variable für aktuelle Zelle
   Dim ByMldg As Byte                              ' Variable Meldung
   Dim WsSh As Worksheet                           ' Variable Tabelle
   Dim ObZelle As Object                           ' Variable für Namen
'GoTo weiter:
   For Each WsSh In Worksheets                     ' Schleife über alle Tabellen der Datei
       ' Prüfen ob Tabelle schon vorhanden
       If InStr(WsSh.Name, "Verknüpfung") > 0 Then
           ByMldg = MsgBox("Eine Tabelle mit dem Namen " _
               & "Verknüfungen ist schon vorhanden, sollen die " _
               & "Daten gelöscht werden", vbYesNo + vbQuestion, _
               "Löschabfrage ?", "", 0)
           If ByMldg = 6 Then              ' Ja wurde gedrückt
               ' Zellen komplett löschen,
               ' da schon bestimmte Formate eingestellt
               WsSh.Cells.Delete
               ' Kennzeichnen dass Tabelle schon vorhanden
               ByMldg = 45
               ' Schleife verlasse, da Tabelle gefunden
               Exit For
           Else
               Exit Sub
           End If
       End If
   Next WsSh
Weiter:
   Application.ScreenUpdating = False              ' Bildschirmaktualisierung ausschalten
   Application.EnableEvents = False                ' Reaktion Eingabe abschalten
   If ByMldg <> 45 Then                            ' Tabelle anlegen falls noch nicht vorhanden
       ' Anlegen hinter der letzten Tabelle ubnd Namen geben
       Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Verknüpfung"
       With ActiveWindow
           .SplitRow = 2
           .FreezePanes = True
       End With
   End If
   With Worksheets("Verknüpfung")
       ' Überschriftszeilen
       ' Formel mit Ergebnis Fehler
       .Cells(1, 1) = "Formel mit Ergebnis Fehler"
       .Cells(2, 1) = "Zelle"
       .Cells(2, 2) = "Tabelle"
       .Cells(2, 3) = "Formel"
       ' Formel zu anderen Arbeitsmappe
       .Cells(1, 5) = "Formel zu anderen Arbeitsmappe"
       .Cells(2, 5) = "Zelle"
       .Cells(2, 6) = "Tabelle"
       .Cells(2, 7) = "Formel"
       ' Formel zu anderen Tabellen in dieser Arbeitsmappe
       .Cells(1, 9) = "andere Tabelle"
       .Cells(2, 9) = "Zelle"
       .Cells(2, 10) = "Tabelle"
       .Cells(2, 11) = "Formel"
       ' restliche Formel
       .Cells(1, 13) = "Rest"
       .Cells(2, 13) = "Zelle"
       .Cells(2, 14) = "Tabelle"
       .Cells(2, 15) = "Formel"
       ' definierte Namen in dieser Arbeitsmappe
       .Cells(1, 17) = "definierte Namen"
       .Cells(2, 17) = "Name"
       .Cells(2, 18) = "Zelle"
       .Cells(2, 19) = "Tabelle"
       Rows("1:2").Font.Bold = True
       For Each WsSh In Worksheets                 ' Schleife über alle Tabellen
           If WsSh.Name <> "Verknüpfung" Then
               ' Schutz aufheben falls vorhanden
               ' WsSh.Unprotect "Passwort"
               On Error Resume Next
               Set RaZelle = WsSh.UsedRange.SpecialCells(xlCellTypeFormulas)
               Set RaZelle = Nothing
               If Err.Number = 0 Then
                   On Error GoTo 0
                   ' Schleife über den benuzten Bereich mit Formel
                   For Each RaZelle In WsSh.UsedRange.SpecialCells(xlCellTypeFormulas)
                       ' Formeln mit Fehler
                       If IsError(RaZelle.Value) Then
                           .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row + 1, 1) _
                               = RaZelle.Address(0, 0)
                           .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 2) _
                               = CStr(WsSh.Name)
                           .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 3) _
                               = "'" & RaZelle.FormulaLocal
                       ' Formel zu anderer Arbeitsmappe
                       ElseIf InStr(RaZelle.Formula, ":\") <> 0 Then
                           .Cells(.Cells(.Rows.Count, 5).End(xlUp).Row + 1, 5) _
                               = RaZelle.Address(0, 0)
                           .Cells(.Cells(.Rows.Count, 5).End(xlUp).Row, 6) _
                               = CStr(WsSh.Name)
                           .Cells(.Cells(.Rows.Count, 5).End(xlUp).Row, 7) _
                               = "'" & RaZelle.FormulaLocal
                       ' Formel zu andere Tabelle
                       ElseIf InStr(RaZelle.Formula, "!") > 1 Then
                           .Cells(.Cells(.Rows.Count, 9).End(xlUp).Row + 1, 9) _
                               = RaZelle.Address(0, 0)
                           .Cells(.Cells(.Rows.Count, 9).End(xlUp).Row, 10) _
                               = CStr(WsSh.Name)
                           .Cells(.Cells(.Rows.Count, 9).End(xlUp).Row, 11) _
                               = "'" & RaZelle.FormulaLocal
                        Else               ' restliche Formeln
                           .Cells(.Cells(.Rows.Count, 13).End(xlUp).Row + 1, 13) _
                               = RaZelle.Address(0, 0)
                           .Cells(.Cells(.Rows.Count, 13).End(xlUp).Row, 14) _
                               = CStr(WsSh.Name)
                           .Cells(.Cells(.Rows.Count, 13).End(xlUp).Row, 15) _
                               = "'" & RaZelle.FormulaLocal
                       End If
                   Next RaZelle
               End If
               On Error GoTo 0                     ' Fehlerbehandlung einschalten
           End If
           ' WsSh.Protect "Passwort"               ' Schutz wieder setzen
       Next WsSh
       ' Programmteil Namen auslesen
       ' Schleife über alle Namen der Datei
       For Each ObZelle In ActiveWorkbook.Names
           .Cells(.Cells(.Rows.Count, 17).End(xlUp).Row + 1, 17) _
               = ObZelle.Name
           With .Cells(.Cells(.Rows.Count, 17).End(xlUp).Row, 18)
               If InStr(ObZelle, "REF") <> 0 Then
                   .Value = Mid(ObZelle, InStr(ObZelle, "!") + 1)
                   .Font.Bold = True
                   .Font.ColorIndex = 3
               ElseIf InStr(ObZelle, "\") <> 0 Then
                   .Value = Mid(ObZelle, InStr(ObZelle, "!") + 1)
                   .Font.Bold = True
                   .Font.ColorIndex = 4
               Else
                   .Value = Mid(ObZelle, InStr(ObZelle, "!") + 1)
               End If
           End With
           If InStr(ObZelle.RefersTo, "!") > 0 Then
               .Cells(.Cells(.Rows.Count, 17).End(xlUp).Row, 19) _
                   = Application.WorksheetFunction.Substitute(Mid(ObZelle, _
                   2, InStr(ObZelle, "!") - 2), "'", "")
           Else
               .Cells(.Cells(.Rows.Count, 17).End(xlUp).Row, 19) _
                   = ObZelle.RefersTo
           End If
       Next
       .Range("B:C,F:G,J:K,N:O, R:S").EntireColumn.AutoFit
       ' Überschriftszeilen
       ' Formel mit Ergebnis Fehler
       .Cells(1, "A") = "Zellen mit Ergebnis Error"
       ' Formel zu anderen Arbeitsmappe
       .Cells(1, "E") = "Formeln zu anderen Arbeitsmappen"
       ' Formel zu anderen Tabellen in dieser Arbeitsmappe
       .Cells(1, "I") = "Formeln zu anderen Tabellen"
       ' restliche Formel
       .Cells(1, "M") = "restliche Formeln"
       ' definierte Namen in dieser Arbeitsmappe
       .Cells(1, "O") = "Namen in dieser Arbeitsmappe"
   End With
Fehler1:
   On Error GoTo 0                                 ' Fehlerbehandlung eimschalten
   If Err <> 0 Then MsgBox "Es ist ein Fehler aufgetreten!"
   Application.ScreenUpdating = True               ' Bildschirmaktualisierung einschalten
   Application.EnableEvents = True                 ' Reaktion Eingabe einschalten
End Sub