修改 经过一番研究后,我偶然发现了handy little shortcut: 只需右键单击左下角的小箭头即可显示所有工作表 - 无需代码!
我有一个包含100个标签的excel工作簿。幸运的是,标签全部编号为1-100。我有一个索引页面,其中包含连续的所有数字,我想在该行旁边添加一行,并带有指向编号选项卡的超链接。
A B
---------------------------
| 1 | link to tab 1 |
---------------------------
| 2 | link to tab 2 |
---------------------------
等...
到目前为止,我发现最有希望的是:
=Hyperlink(“C:\Documents and Settings\Admin1\Desktop\” & A1 & “.xls”,A1)
我知道超链接功能需要:
=HYPERLINK(link_location,friendly_name)
当我手动完成时,我明白了:
=HYPERLINK('1'!$A$1,A1)
所以我想做这样的事情:
=HYPERLINK('& A1 &'!$A$1,A1)
但它不起作用。任何帮助深表感谢。此外,如果有一个更简单的方法来解决这个问题 - 我很满意。
答案 0 :(得分:6)
使用类似的代码
在excel-2003转到Tools-Macro-Macros
并双击CreateTOC
在excel-2007中点击“开发者”标签的“代码”组中的Macros button
,然后点击列表框中的CreateTOC
。
Option Explicit
Sub CreateTOC()
Dim ws As Worksheet
Dim nmToc As Name
Dim rng1 As Range
Dim lngProceed As Boolean
Dim bNonWkSht As Boolean
Dim lngSht As Long
Dim lngShtNum As Long
Dim strWScode As String
Dim vbCodeMod
'Test for an ActiveWorkbook to summarise
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
Exit Sub
End If
'Turn off updates, alerts and events
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
'If the Table of Contents exists (using a marker range name "TOC_Index") prompt the user whether to proceed
On Error Resume Next
Set nmToc = ActiveWorkbook.Names("TOC_Index")
If Not nmToc Is Nothing Then
lngProceed = MsgBox("Index exists!" & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbCritical, "Warning")
If lngProceed = vbYes Then
Exit Sub
Else
ActiveWorkbook.Sheets(Range("TOC_Index").Parent.Name).Delete
End If
End If
Set ws = ActiveWorkbook.Sheets.Add
ws.Move before:=Sheets(1)
'Add the marker range name
ActiveWorkbook.Names.Add "TOC_INDEX", ws.[a1]
ws.Name = "TOC_Index"
On Error GoTo 0
On Error GoTo ErrHandler
For lngSht = 2 To ActiveWorkbook.Sheets.Count
'set to start at A6 of TOC sheet
'Test sheets to determine whether they are normal worksheets
ws.Cells(lngSht + 4, 2).Value = TypeName(ActiveWorkbook.Sheets(lngSht))
If TypeName(ActiveWorkbook.Sheets(lngSht)) = "Worksheet" Then
'Add hyperlinks to normal worksheets
ws.Hyperlinks.Add Anchor:=ws.Cells(lngSht + 4, 1), Address:="", SubAddress:="'" & ActiveWorkbook.Sheets(lngSht).Name & "'!A1", TextToDisplay:=ActiveWorkbook.Sheets(lngSht).Name
Else
'Add name of any non-worksheets
ws.Cells(lngSht + 4, 1).Value = ActiveWorkbook.Sheets(lngSht).Name
'Colour these sheets yellow
ws.Cells(lngSht + 4, 1).Interior.Color = vbYellow
ws.Cells(lngSht + 4, 2).Font.Italic = True
bNonWkSht = True
End If
Next lngSht
'Add headers and formatting
With ws
With .[a1:a4]
.Value = Application.Transpose(Array(ActiveWorkbook.Name, "", Format(Now(), "dd-mmm-yy hh:mm"), ActiveWorkbook.Sheets.Count - 1 & " sheets"))
.Font.Size = 14
.Cells(1).Font.Bold = True
End With
With .[a6].Resize(lngSht - 1, 1)
.Font.Bold = True
.Font.ColorIndex = 41
.Resize(1, 2).EntireColumn.HorizontalAlignment = xlLeft
.Columns("A:B").EntireColumn.AutoFit
End With
End With
'Add warnings and macro code if there are non WorkSheet types present
If bNonWkSht Then
With ws.[A5]
.Value = "This workbook contains at least one Chart or Dialog Sheet. These sheets will only be activated if macros are enabled (NB: Please doubleclick yellow sheet names to select them)"
.Font.ColorIndex = 3
.Font.Italic = True
End With
strWScode = "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)" & vbCrLf _
& " Dim rng1 As Range" & vbCrLf _
& " Set rng1 = Intersect(Target, Range([a6], Cells(Rows.Count, 1).End(xlUp)))" & vbCrLf _
& " If rng1 Is Nothing Then Exit Sub" & vbCrLf _
& " On Error Resume Next" & vbCrLf _
& " If Target.Cells(1).Offset(0, 1) <> ""Worksheet"" Then Sheets(Target.Value).Activate" & vbCrLf _
& " If Err.Number <> 0 Then MsgBox ""Could not select sheet"" & Target.Value" & vbCrLf _
& "End Sub" & vbCrLf
Set vbCodeMod = ActiveWorkbook.VBProject.VBComponents(ws.CodeName)
vbCodeMod.CodeModule.AddFromString strWScode
End If
'tidy up Application settins
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
ErrHandler:
If Err.Number <> 0 Then MsgBox Err.Description & vbCrLf & "Please note that your Application settings have been reset", vbCritical, "Code Error!"
End Sub
答案 1 :(得分:2)
我的片段:
Sub AddLinks()
Dim wksLinks As Worksheet
Dim wks As Worksheet
Dim row As Integer
Set wksLinks = Worksheets("Links")
wksLinks.UsedRange.Delete
row = 1
For Each wks In Worksheets
' Debug.Print wks.Name
wks.Hyperlinks.Add wksLinks.Cells(row, 1), "", wks.Name & "!A1", , wks.Name
row = row + 1
Next wks
End Sub
假设名为“链接”的工作表
答案 2 :(得分:0)
可能不是你的方法的直接答案,但我会创造一些更令人愉悦的东西,比如......某些形状格式化很好,然后将一些基本宏设置为它们,以便选择床单。
这可以很容易地修改为转到特定地址(例如Go to Ctrl+G
内置的Excel功能)。希望这有助于文件的时尚风格:)
修改<!/强>
不知道为什么我的答案获得-1评级。正如我所说,它是另一种选择,而不是对给定问题的直接解决方案。尽管如此,我确实认为我最初的答案是肤浅的,没有经过验证/工作的VBA代码,因此我在下面开发了一个实用的例子:
Sub Add_Link_Buttons()
'Clear any Shapes present in the "Links" sheet
For j = ActiveSheet.Shapes().Count To 1 Step -1
ActiveSheet.Shapes(j).Delete
Next j
'Add the shapes and then asign the "Link" Macros
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveSheet.Shapes.AddShape Type:=msoShapeRoundedRectangle, Left:=50, Top:=i * 25, Width:=100, Height:=25
ActiveSheet.Shapes(i).OnAction = "Select_Sheet" & i
'even add the the sheet Name as Test:
ActiveSheet.Shapes(i).TextFrame2.TextRange.Characters.Text = Sheets(i).Name
Next i
End Sub
“basic Select Macros”应该是:
Sub Select_Sheet1()
ActiveWorkbook.Sheets(1).Select
End Sub
Sub Select_Sheet2()
ActiveWorkbook.Sheets(2).Select
End Sub
Sub Select_Sheet3()
ActiveWorkbook.Sheets(3).Select
End Sub
' and so on!
' Note! to link a specific address within the sheets use the range like in 'Sheets(1).Range("A1").Select
同样,这是一种替代方案,不会添加超链接(如询问的那样),但可以从同一位置选择工作表。
要解决外部文件链接的按钮,只需定义address
&gt; filename/workbook
Sheets()
和Open
;)
答案 3 :(得分:0)
以下是我使用的代码:
Sub CreateIndex()
'This macro checks for an Index tab in the active worksheet and creates one if one does not already exist.
'If an Index tab already exists, the user is asked to continue. If they continue, the original Index tab is replaced by a new Index tab. If they do not continue, the macro stops.
'The user is then asked if they want to create a link back to the Index tab on all other worksheets (yes or no) and the macro acts accordingly.
Dim wsIndex As Worksheet
Dim wSheet As Worksheet
Dim retV As Integer
Dim i As Integer
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set wsIndex = Worksheets.Add(Before:=Sheets(1))
With wsIndex
On Error Resume Next
.Name = "Index"
If Err.Number = 1004 Then
If MsgBox(Prompt:="A sheet named ""Index"" already exists. Do you wish to continue by replacing it with a new Index?", _
Buttons:=vbInformation + vbYesNo) = vbNo Then
.Delete
MsgBox "No changes were made."
GoTo EarlyExit:
End If
Sheets("Index").Delete
.Name = "Index"
End If
On Error GoTo 0
retV = MsgBox("Create links back to ""Index"" sheet on other sheets?", vbYesNo, "Linking Options")
For Each wSheet In ActiveWorkbook.Worksheets
If wSheet.Name <> "Index" Then
i = i + 1
If wSheet.Visible = xlSheetVisible Then
.Range("B" & i).Value = "Visible"
ElseIf wSheet.Visible = xlSheetHidden Then
.Range("B" & i).Value = "Hidden"
Else
.Range("B" & i).Value = "Very Hidden"
End If
.Hyperlinks.Add Anchor:=.Range("A" & i), Address:="", SubAddress:="'" & wSheet.Name & "'!A1", TextToDisplay:=wSheet.Name
If retV = 6 And wSheet.Range("A1").Value <> "Index" Then
wSheet.Rows(1).Insert
wSheet.Range("A1").Hyperlinks.Add Anchor:=wSheet.Range("A1"), Address:="", SubAddress:="'" & .Name & "'!A1", TextToDisplay:=.Name
End If
End If
Next wSheet
.Rows(1).Insert
With .Rows(1).Font
.Bold = True
.Underline = xlUnderlineStyleSingle
End With
.Range("A1") = "Sheet Name"
.Range("B1") = "Status"
.UsedRange.AutoFilter
Rows("2:2").Select
ActiveWindow.FreezePanes = True
Application.Goto Reference:="R1C1"
.Columns("A:B").AutoFit
End With
With ActiveWorkbook.Sheets("Index").Tab
.Color = 255
.TintAndShade = 0
End With
EarlyExit:
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
-Mike