AW: Zellennamen aus nicht benachbarten Spalten vergebe
28.11.2011 23:10:38
fcs
Hallo Ingo,
das funktioniert leider nicht. So weit reichen die Automatismen in Excel nicht.
Ich hab dir mal ein entsprechendes Makro erstellt.
Gruß
Franz
'Diesen Code in der persönlichen Arbeitsmappe in einem allgemeinen Modul einfügen
Sub aaNamenZuweisen()
'Weist den Zellen unterhalb des selektierten Zellbereichs den Textinhalt der Zellen _
jeweils als Namen zu.
'Vor dem Start des Makros den Zellbereich mit den Namen selektieren!
Dim wb As Workbook
Dim rngSelektion As Range, rngZelle As Range, strName As String
Set wb = ActiveWorkbook
Set rngSelektion = Selection
For Each rngZelle In rngSelektion.Cells
strName = rngZelle.Text
If strName "" Then
If fncCheckName(sName:=strName) = False Then
wb.Names.Add Name:=strName, RefersTo:="='" & rngZelle.Parent.Name _
& "'!" & rngZelle.Offset(rngSelektion.Rows.Count, 0).AddressLocal
Else
Select Case MsgBox("Name """ & strName & """ existiert schon für" & vbLf _
& "Zelle/Bereich " & wb.Names(strName).RefersTo & vbLf _
& "Name jetzt der Zelle """ _
& rngZelle.Offset(rngSelektion.Rows.Count, 0).AddressLocal & """ zuweisen?", _
vbQuestion + vbYesNoCancel, _
"Namen anlegen")
Case vbCancel
Exit For
Case vbYes
wb.Names.Add Name:=strName, RefersTo:="='" & rngZelle.Parent.Name _
& "'!" & rngZelle.Offset(rngSelektion.Rows.Count, 0).AddressLocal
Case vbNo
End Select
End If
Else
MsgBox "Zelle """ & rngZelle.Address & """ ist leer. Der Zelle """ & _
rngZelle.Offset(rngSelektion.Rows.Count, 0).AddressLocal _
& """ wird kein Name zugewiesen!", vbInformation + vbOKOnly, _
"Namen anlegen"
End If
Next
End Sub
Function fncCheckName(ByVal sName As String, Optional wbTest As Workbook) As Boolean
'Function prüft, ob Name schon vorhanden ist. Wenn JA, dann Ergebnis = True
Dim vartest As Long, oName As Name
On Error GoTo Fehler
If wbTest Is Nothing Then Set wbTest = ActiveWorkbook
Set oName = wbTest.Names(sName)
fncCheckName = True
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case 1004 'Name existiert nicht
fncCheckName = False
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Set oName = Nothing
End Function