versuche es mal hiermit
23.12.2009 21:54:20
Tino
Hallo,
ok. verstehe was Du meinst, hoffe ich.
Teste mal diesen Code.
Sub alle_Namen_löschen()
Dim oName As Name, rngVerweis As Range
Dim meArNamen(), i As Integer, strName$
'sollte der Name eine Formel sein
On Error Resume Next
'Schleife über alle Namen und Namen der aktiven Tabelle Sammeln
For Each oName In ActiveWorkbook.Names
'Namen versuchen einem Rangeobjekt zuzuweisen
Set rngVerweis = Range(oName.Name)
'ist Rangeobjekt ein Zellbereich?
If Not rngVerweis Is Nothing Then
'Befindet sich dieses Rangeobjekt auf der aktuellen Tabelle?
If Not oName.Name Like "*!*" Then
'enferne Hochkomme
strName$ = Replace(oName.Name, "'", "")
'entferne Tabellenname
strName$ = Replace(strName$, rngVerweis.Parent.Name & "!", "")
If i > 0 Then
If Not IsNumeric(Application.Match(strName$, meArNamen, 0)) Then
Redim Preserve meArNamen(i)
meArNamen(i) = strName$
i = i + 1
End If
Else
Redim Preserve meArNamen(i)
meArNamen(i) = strName$
i = i + 1
End If
End If
End If
Next oName
If i > 0 Then
'Schleife über alle Namen
For Each oName In ActiveWorkbook.Names
'Namen versuchen einem Rangeobjekt zuzuweisen
Set rngVerweis = Range(oName.Name)
'ist Rangeobjekt ein Zellbereich?
If Not rngVerweis Is Nothing Then
'ist im Namen ein !
If oName.Name Like "*!*" Then
'enferne Hochkomme
strName$ = Replace(oName.Name, "'", "")
'entferne Tabellenname
strName$ = Replace(strName$, rngVerweis.Parent.Name & "!", "")
'ist der Name bereits vergeben, Namen löschen
If IsNumeric(Application.Match(strName$, meArNamen, 0)) Then
oName.Delete
End If
End If
End If
Next oName
End If
'On Error GoTo 0 ' nur nötig wenn Makro hier weiter laufen sollte
End Sub
Gruß Tino
