Skapa namnlista för aktiv arbetsbok

Visserligen har MS Excel en inbyggd funktion för att generera en namnlista men den ger inga möjligheter att snabbt gå till en namngivet cell eller cellområde (se Skapa namnförteckning).

Här demonstreras hur vi kan skapa en namnlista för aktiv arbetsblad och som har hyperlänkar till de namngivna cellområdena.

Se också:


 

Option Explicit

Sub Skapa_Namn_Lista()

'© 2002 Alla rättigheter XL-Dennis
Dim rnOmrade As Range
Dim nNamn As Name
Dim lnNamn As Long, lnAntal As Long

'Kontroll om namn finns i arbetsboken.
For Each nNamn In ActiveWorkbook.Names
     lnAntal = lnAntal + 1
Next nNamn

'Meddelande om arbetsboken saknar namn.
If lnAntal = 0 Then
   MsgBox "Hittade inga namn.", vbInformation, "Skapa namnlista"
   Exit Sub
End If

With Application
       .DisplayAlerts = False
       .ScreenUpdating = False
End With

'Tar bort eventuell tidigare arbetsblad med namnlist och lägger til
'nytt arbetsblad.
On Error Resume Next
With ActiveWorkbook
      .Sheets("Namnlista").Delete
      .Sheets.Add
End With
On Error GoTo 0

'Formatering av det insatta nya arbetsbladet.
With ActiveSheet
       .Name = "Namnlista"
       .Cells(1, 1).Value = "Namn:"
       .Cells(1, 2).Value = "Värde:"
       .Cells(1, 3).Value = "Refererar till:"
       With .Range("A1:C1")
              .Font.Bold = True
              .Font.ColorIndex = 10
              .Font.Size = 10
       End With
End With

'Loopar igenom namnkollektionen och skriver namnuppgifterna till
'arbetsbladet "Namnlista".
lnNamn = 2
For Each nNamn In ActiveWorkbook.Names
       'Utskriftsområde ska inte visas i namnlistan
       If nNamn.Name Like "*!Print_*" Then GoTo Fortsatt
       ActiveSheet.Cells(lnNamn, 1).Value = nNamn.Name
       ActiveSheet.Hyperlinks.Add _
                                Anchor:=ActiveSheet.Cells(lnNamn, 1), _
                                Address:="", _
                                SubAddress:=nNamn.Name

       With ActiveSheet
              With .Cells(lnNamn, 3)
                     .Value = "'" & nNamn.RefersTo
                     .InsertIndent 1
              End With
       End With

       On Error Resume Next
       Set rnOmrade = nNamn.RefersToRange

       'Om namnet omfattar ett cellområde kan inget värde
       'anges varför "Inget" ska anges istället för #Värdefel!

       If rnOmrade.Cells.Count > 1 Then
              ActiveSheet.Cells(lnNamn, 2).Value = "Inget"
       Else
              With ActiveSheet.Cells(lnNamn, 2)
                   .Value = nNamn.Value
                   .NumberFormat = rnOmrade.NumberFormat
              End With
       End If

       On Error GoTo 0

       lnNamn = lnNamn + 1
Fortsatt:
Next nNamn

Columns("A:C").EntireColumn.AutoFit
Columns("B").HorizontalAlignment = xlCenter

With Application
       .Calculation = xlCalculationAutomatic
       .ScreenUpdating = True
End With
End Sub