ساخت فهرست شیتها در اکسل با استفاده از کد vba
این ماژول اسامی شیتهای موجود در فایلتان را بصورت فهرست لینک دار در یک شیت جدید ایجاد خواهد کرد کافی است در اکسل به محیط ویژوال بیسیک رفته و فایل را وارد نمائید. با اجرای ماکرو فهرست ساخته خواهد شد.
Sub Build_Sheet_Navigator_with_Goto_Button()
' On Error Resume Next
Application.DisplayAlerts = False
Application.DisplayAlerts = False
Call Insert_Navigator_WorkSheet 'Inset Sheet_Navigator worksheet
Call DeleteAllShapes 'first remove pervious Button
Call Insert_Goto_Home_Button ' Insert Buttons
Call ShapePrint 'Does not Print Button
Worksheets("Sheet_Navigator").Shapes("HomeBtn").Delete
Worksheets("Sheet_Navigator").Range("A2").Clear
Worksheets("Sheet_Navigator").Range("A2")= "فهرست مطالب"
Worksheets("Sheet_Navigator").Activate
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub
Private Sub Insert_Goto_Home_Button()
On Error Resume Next
For Each sh In Worksheets
With sh.Shapes.AddShape(msoShapeRectangle, 2, 2, 45, 15)
.Name = "HomeBtn"
.Fill.ForeColor.RGB = RGB(255, 0, 0)
.TextFrame.Characters.Text = "Home"
.Line.Visible = False
End With
sh.Hyperlinks.Add Anchor:=sh.Shapes("HomeBtn"), Address:="", SubAddress:="Sheet_Navigator!A1", ScreenTip:="Click Here to go Sheet_Navigator Worksheet"
Next
End Sub
Private Sub Insert_Navigator_WorkSheet()
On Error Resume Next
Worksheets("Sheet_Navigator").Delete
Worksheets.Add(Sheets(1)).Name = "Sheet_Navigator"
For Each sh In Worksheets
i = i + 1
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 1, 1), Address:="", SubAddress:="'" & sh.Name & "'" & "!A1", TextToDisplay:=sh.Name
Next
With Columns("A:A")
.EntireColumn.AutoFit
HorizontalAlignment = xlLeft
End With
End Sub
Private Sub DeleteAllShapes()
On Error Resume Next
For Each sh In Worksheets
sh.Shapes("HomeBtn").Delete
Next
End Sub
Private Sub ShapePrint()
'This Procedure set button print property to false which Button does not print
On Error Resume Next
Application.ScreenUpdating = False
For Each sh In Worksheets
sh.Activate
sh.Shapes("HomeBtn").Select
Selection.PrintObject = False
sh.Cells(1, 1).Activate
Next
End Sub