Zellen eines Bereiches nach einem bestimmten Schema benennen

Gepostet am: Jan 21, 2011 10:38:30 PM

Wer schon mal vor dem Problem gestanden ist mehrere Zellen untereinander oder nebeneinander nach einem gewissen Schema benennen zu müssen weiß, dass dies unter Umständen (einen entsprechend großen Bereich vorausgesetzt) eine ganz schöne Schreiberei ist. 

Um die Problematik zu verdeutlichen ein Screenshot, was erreicht werden will. [Die Namen in der Zelle stellen den Namen der Zelle dar]

Hier die Lösung für dieses Problem als Makro

Zellen_eines_Bereiches_benennen

Public Sub Zellen_eines_Bereiches_benennen()Dim myNames As StringDim RI As IntegerDim CI As IntegerDim strR As StringDim strC As String  Application.DisplayAlerts = FalseOn Error GoTo Err_Handler Dim myRange As Range Set myRange = Application.InputBox("Wählen Sie den Bereich aus, den Sie benennen möchten:", "Bereich auswählen:", , , , , , 8)If myRange.Columns.Count > 9999 Then     strC = "00000"ElseIf myRange.Columns.Count > 999 Then     strC = "0000"ElseIf myRange.Columns.Count > 99 Then     strC = "000"ElseIf myRange.Columns.Count > 9 Then     strC = "00"Else     strC = "0"End IfIf myRange.Rows.Count > 9999 Then     strR = "00000"ElseIf myRange.Rows.Count > 999 Then     strR = "0000"ElseIf myRange.Rows.Count > 99 Then     strR = "000"ElseIf myRange.Rows.Count > 9 Then     strR = "00"Else     strR = "0"End IfIf myRange.Columns.Count = 1 And myRange.Rows.Count >= 1 Then     myNames = InputBox("Geben Sie den Namen der Felder ein [%R% für den Zähler der Zeile]", "Eingabe")     If InStr(myNames, "%R%") <> 0 Then         For RI = 1 To myRange.Rows.Count             myRange.Cells(RI, 1).Select             'Range bennenen             ActiveWorkbook.Names.Add Name:=CStr(Replace(myNames, "%R%", Format(RI, strR))), RefersTo:=ActiveCell         Next     End IfElseIf myRange.Rows.Count = 1 And myRange.Columns.Count >= 1 Then     myNames = InputBox("Geben Sie den Namen der Felder ein [%C% für den Zähler der Spalten]", "Eingabe")     If InStr(myNames, "%C%") <> 0 Then         For CI = 1 To myRange.Columns.Count             myRange.Cells(1, CI).Select             'Range bennenen             ActiveWorkbook.Names.Add Name:=CStr(Replace(myNames, "%C%", Format(CI, strC))), RefersTo:=ActiveCell         Next     End IfElseIf myRange.Rows.Count > 1 And myRange.Columns.Count > 1 Then     myNames = InputBox("Geben Sie den Namen der Felder ein [%C% für den Zähler der Spalten und %R% für den Zähler der Zeilen]", "Eingabe")     If InStr(myNames, "%C%") <> 0 And InStr(myNames, "%R%") Then         For CI = 1 To myRange.Columns.Count             For RI = 1 To myRange.Rows.Count                 myRange.Cells(RI, CI).Select                 'Range bennenen                 ActiveWorkbook.Names.Add Name:=CStr(Replace(Replace(myNames, "%C%", Format(CI, strC)), "%R%", Format(RI, strR))), RefersTo:=ActiveCell             Next         Next     End If     Exit Sub      Err_Handler:     MsgBox ("Beachten Sie, dass der Name gültig sein muss.")End IfEnd Sub