Tekstfelt, gå til fane?

put koden ind i ThisWorkbook
(tast 0-90 i A1 for Ark-valg) kan ændres til anden celle.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
If [A1] < 0 Or [A1] > 90 Or [A1] = "" Then Exit Sub
Sheets(CStr(1000 + [A1])).Select: [A1] = "": [A1].Select
End Sub

Lav et ekstra tomt ark.
stå i en celle og gå ind i "Indsæt" menuen.
Vælg "Hyperlink"
Hyperlink til "En placering i dette dokument"
Her kan du se dine arkfaner listet.
Vælg den første, som indsættes i den valgte celle.
Nu kan du med musen kopiere links til alle dine ark.
Nu kan du hoppe direkte til et ark bare ved at klikke på link'et.

Hilsen KOL

Jeg lavede denne engang, den laver et ark, med navnet "Nenu", med hyperlink til de andre ark.

Jeg ved ikke om det er det du søger.

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.Holger Bak ©")
    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"
            ActiveCell.Font.Color = vbBlue
            ActiveCell.Font.Bold = True
            ActiveCell.Font.Italic = True

            Range("A1:E1").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:f31").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:a150").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:A150").Select
        Selection.Sort Worksheets("Menu").Columns("A"), Order1:=xlAscending, Header:=xlGuess, _
                      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

        '--------------- Flytter data over i 4 kolonner ------------------------
        Range("A31:A59").Select
        Selection.Cut
        Range("B2").Select
        ActiveSheet.Paste
        Range("A60:A88").Select
        Selection.Cut
        Range("C2").Select
        ActiveSheet.Paste
        Range("A89:A117").Select
        Selection.Cut
        Range("d2").Select
        ActiveSheet.Paste
        Range("A118:A146").Select
        Selection.Cut
        Range("e2").Select
        ActiveSheet.Paste
        Columns("A:E").Select
        Selection.ColumnWidth = 22
        Range("d30").Select

    Else
        Exit Sub
    End If
End Sub

Forslag: Ved åbning af mappen vises en lille formular - modeless - d.v.s. at der kan arbejdes i et regneark samtidig med at formularen er åben. Indtast det ønskede arknr. Der kontrolleres om arket eksisterer - ellers fejlmelding. Vis arket eksisterer - vises dette - medens formularen stadig er åben.

VBA-kode er følgende:
I ThisWorkBook:

Sub workbook_activate()
    Load UserForm1
    UserForm1.Show 0
End Sub

I formularen (Indeholder en textbox samt en knap:

Private Sub CommandButton1_Click()
    Unload UserForm1
End Sub
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If TextBox1 <> "" Then
        If findesArk(TextBox1) = True Then
            ActiveWorkbook.Sheets(TextBox1.Value).Activate
        Else
            MsgBox ("Ark kunne findes ikke")
        End If
    End If
End Sub
Private Function findesArk(ark)
Dim sh
    For Each sh In ActiveWorkbook.Sheets
        If sh.Name = ark Then
            findesArk = True
            Exit Function
        End If
    Next sh
    findesArk = False
End Function

Igivet fald - send en mail til pb@supertekst-it.dk - så sender jeg hele filen.

Hmm hælder mest til excelents forslag... men det virker ikke. Der sker ikke en snus når jeg opdatere (I mit tilfælde) I20... nogle råd på hvad jeg har gjort galt, har en kode der ser sådanne ud:


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Range("I20")) Is Nothing Then Exit Sub
If [I20] < 0 Or [I20] > 90 Or [A1] = "" Then Exit Sub
Sheets(CStr(10 + [I20])).Select: [I20] = "": [I20].Select
End Sub

har rettet lidt - hus put i ThisWorkbook

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, Range("I20")) Is Nothing Then Exit Sub
If [I20] < 0 Or [I20] > 90 Or [I20] = "" Then Exit Sub
Sheets(CStr(1000 + [I20])).Select: [I20] = "": [I20].Select
End Sub

husk du skal kun taste 11 for at komme til 1011

OG Excelent - det virker perfekt - tak for hjælpen send det som et svar og jeg sender lidt point.

Tak til de øvrige som forsøgte.

ok velbekom