Vedrørende, http://eksperten.dk/spm/428409 Menu på ark 1

smid lige den kode du bruger nu, herind.
så skal jeg se på den

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
R = 2 ' 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.Holger Bak ©"
  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:D41").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

    If ws.Name = "Menu" Then GoTo Næste ' Hopper over hovedarket "Menu"
 
  ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & ws.Name & "'" & "!A1"
    Worksheets("Menu").Cells(R, K).FormulaR1C1 = ws.Name ' skriver hyperlink på alle sider inden for området
    Worksheets("Menu").Cells(R, K + 1) = Sheets(ws.Name).Range("Q2")
    R = R + 1
    If R = 42 Then
    R = 2
    K = 3
    End If
   
Næste:
  Next ws
  Else
Exit Sub
End If
End Sub

Jeg bruger din kode, med den rettelse at hyperlinks er fordelt på kun to kolonner A og D.

Public Sub Menu()
Dim W As Integer, K As Integer, A As Integer, ws As Variant, NewSheet As Variant
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    v.Holger Bak ©"
  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 kolonne 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("A41:A80.Select
    Selection.Cut
    Range("C2").Select
    ActiveSheet.Paste
    Columns("A:D").Select
    Selection.ColumnWidth = 22
Range("d30").Select

   
Range("d30").Select
       
Else
Exit Sub
End If
End Sub

Jeg prøvede forslaget, 01/11-2004 21:56:58
det virker.
Hvis jeg udvider antallet af ark er det så blot i disse linier jeg skal rette?

Range("a2:D41").Select 

If R = 42 Then

Nu har jeg ændret, så tæller den selv, og du behøver ikke at gøre noget.


Public Sub Menu()
Dim R As Integer, K As Integer, A As Integer, LR 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
R = 2 ' 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:
LR = Int((Worksheets.Count) / 2) + 1
  Worksheets("Menu").Activate
  Range("a1").Select
  If ActiveCell.Value = "" Then
  ActiveCell.Value = "MENU Styring    v.Holger Bak ©"
  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:D" & LR).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

    If ws.Name = "Menu" Then GoTo Næste ' Hopper over hovedarket "Menu"
 
  ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & ws.Name & "'" & "!A1"
    Worksheets("Menu").Cells(R, K).FormulaR1C1 = ws.Name ' skriver hyperlink på alle sider inden for området
    Worksheets("Menu").Cells(R, K + 1) = Sheets(ws.Name).Range("Q2")
    R = R + 1
    If R = LR + 1 Then
    R = 2
    K = 3
    End If
   
Næste:
  Next ws
  Else
Exit Sub
End If
End Sub

Det er kun A2 der fungerer som hyperlink??

sorry

Public Sub Menu()
Dim R As Integer, K As Integer, A As Integer, LR 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
R = 2 ' 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:
LR = Int((Worksheets.Count) / 2) + 1
  Worksheets("Menu").Activate
  Range("a1").Select
  If ActiveCell.Value = "" Then
  ActiveCell.Value = "MENU Styring    v.Holger Bak ©"
  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:D" & LR).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
Cells(R, K).Select
    If ws.Name = "Menu" Then GoTo Næste ' Hopper over hovedarket "Menu"
 
  ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & ws.Name & "'" & "!A1"
    Worksheets("Menu").Cells(R, K).FormulaR1C1 = ws.Name ' skriver hyperlink på alle sider inden for området
    Worksheets("Menu").Cells(R, K + 1) = Sheets(ws.Name).Range("Q2")
    R = R + 1
    If R = LR + 1 Then
    R = 2
    K = 3
    End If
   
Næste:
  Next ws
  Else
Exit Sub
End If
End Sub

Du skal have mange tak, det rígtig god funktion du har fået lavet.

tak for rosen og point ;-))