Automatisk gernereing af hyperlink via VBA

Jeg lavede denne engang, den laver et ark der hedder Menu, og sætter hyperlink til alle andre ark ind på siden.

Jeg ved ikke om det er det du efterlyser.

Public Sub Menu()
    Dim W As Integer, K As Integer, A As Integer
    A = MsgBox("Vil du indsætte et ark ved navn MENU, eller opdatere eksisterende, hvor der er Hyperlink til dine ark", vbYesNo, "MENU OPRETTER  v.Kabbak ©")
    If A = 6 Then
        W = 1    ' styrer række inden for hyperlink
        K = 1    ' styrer kolonner inden for hyperlink
        For Each ws In Worksheets
            If ws.Name = "Menu" Then GoTo Findes
        Next ws

        Set NewSheet = Worksheets.Add    ' opretter nyt ark
        NewSheet.Name = "Menu"        ' navngiver det nye ark

Findes:
        Worksheets("Menu").Activate
        Range("a1").Select
        If ActiveCell.Value = "" Then
            ActiveCell.Value = "MENU Styring    v.Kabbak ©"
            ActiveCell.Font.Color = vbBlue
            ActiveCell.Font.Bold = True
            ActiveCell.Font.Italic = True

            Range("A1:i1").Select
            With Selection
                .HorizontalAlignment = xlCenter
            End With
            Selection.Merge
            With Selection.Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
                .ColorIndex = 3
            End With
            With Selection.Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlMedium
                .ColorIndex = 3
            End With
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlMedium
                .ColorIndex = 3
            End With
            With Selection.Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
                .ColorIndex = 3
            End With
        End If
        Range("a2:i31").Select            ' sletter alle data i området til hyperlink
        Selection.ClearContents            '    der kan jo være fjernet sider ???
        Range("a2").Select
        '-----------------------------------------Der laves hyperlink til alle ark  -------------
        For Each ws In Worksheets
            Worksheets("Menu").Range("a2:a260").Cells(W, K).Select    ' reseverer et område til at skrive hyperlink i

            If ws.Name = "Menu" Then GoTo Næste    ' Hopper over hovedarket "Menu"

            ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & ws.Name & "'" & "!A1"
            ActiveCell.FormulaR1C1 = ws.Name    ' skriver hyperlink på alle sider inden for området
            W = W + 1
Næste:
        Next ws
        '------------------------------Soterer kollonne A ----------------------------
        Range("A2").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
                      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                      DataOption1:=xlSortNormal

        '--------------- Flytter data over i kolonner ------------------------
        R = 2
        For I = 31 To 252 Step 28
            Range("A" & I & ":A" & I + 28).Cut
            Cells(2, R).Select
            ActiveSheet.Paste
            R = R + 1
        Next
        Columns("A:I").Select
        Selection.EntireColumn.AutoFit
        Range("A1").Select

    Else
        Exit Sub
    End If
End Sub

Hej kabbak! Er lige på vej i møde men kigger på det senere!

Indtil videre tak!

\Gnalling1

Hej kabbak!

Det er meget tæt på. Jeg har bare lidt problemer, når jeg siger "Nej" til at indsætte et ark, der hedder "Menu". Jeg har et ark, der hedder "Info", hvor de informationer, du hjalp med mig i går (alle arknavnene) står. Jeg ville egentlig gerne kombinere dem ved at have dem i kolonne A og så de tilhørende hyperlinks i kolonne B. Jeg smider gerne 30 points ekstra i, hvis man kan gøre det, da det jo nu udvikler sig :o). Er det muligt?

\Gnalling1

Public Sub Arknavne()
Rw = 2
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Ark1" Then
Cells(Rw, 1) = ws.Name
Cells(Rw, 2).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        ws.Name & "!A1"
    Cells(Rw, 2).FormulaR1C1 = ws.Name
Rw = Rw + 1
End If
Next
End Sub

Virker perfekt! Tusind, tusind tak! Hvordan får du 30 ekstra points?

:o) Gnalling1

Hej kabbak!

Jeg har lige prøvet at kopiere koden over i mit "rigtige" dokument. Koden virker perfekt i min test, men i det "rigtige" dokumnent skrives der "Referencen er ugyldig". Jeg kan se, at der bliver sat 3 skråstreger før filnavnet file:///\\filnavn.xls. Har du prøvet det?

Gnalling1

prøv denne, det kan være du har arknavne med mellemrum, eller du har ikke koden i den Workbook den skal virke i.

denne linie
For Each ws In ThisWorkbook.Worksheets
siger "for hver side, i den Workbook som koden er i"

hvis den skal virke fra en anden Workbook, skal linien se sådan ud
For Each ws In ActiveWorkbook.Worksheets


Public Sub Arknavne()
Rw = 2
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "Ark1" Then
Cells(Rw, 1) = ws.Name
Cells(Rw, 2).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        "'" & ws.Name & "'!A1"
    Cells(Rw, 2).FormulaR1C1 = ws.Name
Rw = Rw + 1
End If
Next
End Sub

Det virker perfekt. Skal jeg bare oprette en ny med "Points til kabbak"?

\Gnalling1

nej, dette er ok

Tak igen, kabbak!