Is there any way to align Center Header in Excel? I know there is no any built in solution but is there any VBA code that would work. I have been trying copying cells to header, setting center header with VBA but my Center Header is "Align Center" all the time.
I have even found very complex code to calculate length of sentences and add spaces to each row but it doesn't really work correctly.
I can also set rows to repeat on top and forget about header but what about footer then? How I can set Center Footer to align my two row text to align left?
I have tried:
With ActiveSheet.PageSetup
.LeftHeader = Range("a1").Value & " " & Range("b1").Value & " " & Range("a2").Value & " " & Range("b2").Value
End With
Also sending named range to header:
Option Explicit
Sub SetCenterHeader()
Dim txt As String
Dim myRow As Range
With Range("NorthHead") ' reference named range
For Each myRow In .Rows ' loop through referenced range rows
txt = txt & Join(Application.Transpose(Application.Transpose(myRow.Value)), " ") & vbLf ' update 'txt' with current row cells values joined and separated by a blank
Next
End With
ActiveSheet.PageSetup.CenterHeader = Left(txt, Len(txt) - 1) ' set CenterHeader with resulting 'txt' excluding last vblf character
ActiveWindow.SelectedSheets.PrintOut Copies:=1
End Sub
Result is always the same:
May try the following workaround and modify to your requirements
Sub test2()
Dim CenHd1 As String, CenHd2 As String, Fname As String
Dim Rng As Range
Dim Sht As Worksheet, MnSht As Worksheet
Dim Cht As ChartObject
Set Sht = ThisWorkbook.Worksheets(3)
Set MnSht = ThisWorkbook.Worksheets(1)
Set Rng = Sht.Range("F1:F2")
CenHd1 = "Excel"
CenHd2 = "I am already left Aligned"
Sht.Range("F1").Value = CenHd1
Sht.Range("F2").Value = CenHd2
Sht.Activate
ActiveWindow.DisplayGridlines = False
With Rng
.Columns.AutoFit 'added after taking trial snapshot to perfectly center and left align
.HorizontalAlignment = xlLeft
.Font.Name = "Bookman Old Style"
.Font.Size = 12
'May specify other visual effects
End With
Rng.CopyPicture xlScreen, xlPicture
Set Cht = Sht.ChartObjects.Add(0, 0, Rng.Width * 1.01, Rng.Height * 1.01)
Cht.Name = "TmpChart"
Sht.Shapes("TmpChart").Line.Visible = msoFalse
Cht.Chart.Paste
Fname = "C:\Users\user\Desktop\CentHead " & Format(Now, "dd-mm-yy hh-mm-ss") & ".jpg"
Cht.Chart.Export Filename:=Fname, Filtername:="JPG"
DoEvents
Cht.Delete
ActiveWindow.DisplayGridlines = True
MnSht.Activate
With MnSht.PageSetup.CenterHeaderPicture
.Filename = Fname
'.Height = 275.25
'.Width = 463.5
'.Brightness = 0.36
'.ColorType = msoPictureGrayscale
'.Contrast = 0.39
'.CropBottom = 0
'.CropLeft = 0
'.CropRight = 0
'.CropTop = 0
End With
'Enable the image to show up in the center header.
MnSht.PageSetup.CenterHeader = "&G"
'for Trial only
ActiveWindow.View = xlPageLayoutView
' Clear junk files
If Dir(Fname) <> "" Then Kill (Fname)
End Sub
Tried as follows
the code could also be modified as a function / procedure with parameters for repeated use with different Sheets, Workbooks etc. Hope it will help to serve the purpose.
Related
I have a code for inserting an attached file to a certain column and resizing it so that it perfectly fills the cell. Only problem I have now is that the object is just a blank rectangle and hard to spot if there is even anything in the cell.
I've tried IconLabel:=Range("A" & ActiveCell.Row) so that it shows the ID # of the row but it seems to show it very stretched out and to the point where you can't see anything.
Sub Macro1()
Range("X" & ActiveCell.Row).Select
Dim vFile As Variant, Sh As Object
vFile = Application.GetOpenFilename("All Files,*.*", Title:="Find file to insert")
If vFile = False Then Exit Sub
Dim OleObj As OLEObject
Set OleObj = ActiveSheet.OLEObjects.Add(Filename:=vFile, Link:=False, DisplayAsIcon:=True, IconFileName:= _
"C:\WINDOWS\Installer\{90110409-6000-11D3-8CFE-0150048383C9}\xlicons.exe", _
IconIndex:=0, IconLabel:=Range("A" & ActiveCell.Row).Value)
OleObj.ShapeRange.LockAspectRatio = msoFalse
OleObj.Height = Range("X" & ActiveCell.Row).Height
OleObj.Width = Range("X" & ActiveCell.Row).Width
End Sub
This would make the cell red, because of the vbRed, furthermore, it would be about 4 times less than the standard cell:
With OleObj
.ShapeRange.LockAspectRatio = msoFalse
.Height = Range("X" & ActiveCell.Row).Height / 2
.Width = Range("X" & ActiveCell.Row).Width / 2
.Interior.Color = vbRed
End With
Thus, it would be different and visible. These are the other built-in colors, from the VBA library (Press F2):
OK I will reformulate the question.
I have a worksheet with a tab named"My INT".
This tab contains a data table and a button with an assigned macro called "importRMR". code below:
Sub importRMR()
Dim rng As Range
Set rng = ActiveSheet.Range("G3")
Sheets.Add(After:=ActiveSheet).Name = "RMR " & Format(Date, "DD-MM-YY")
ActiveSheet.Buttons.Add(966.75, 27.75, 153.75, 125.25).Select
Selection.OnAction = "Cimp"
Selection.Characters.Text = "Importuj"
With Selection.Characters(Start:=1, Length:=13).Font
.Name = "Tahoma"
.FontStyle = "Standaard"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
End Sub
This creates a tab with a specific name :RMR " & Format(Date, "DD-MM-YY")
NOw I manually paste the table( always identical ) to the newly created tab "RMR 03/08/2018". the next step is to click the button in this tab ( Importuj) and the result I am aiming for is to :
1. Vlookup data in tab "my INT" where the range( lookup array) is tab "RMR" and then delete the rmr tab.
such procedures like triming the data pasting values and so on I am able to do, just the vlookup but is a problem.
my current code for "importuj " button is:
ub TEST()
Dim DOTR As String
Dim shT As String
Set shT = Sheets(DOTR).Range("E2:H584")
'shT = Sheets(DOTR).Range("c1:e2").Select
DOTR = "RMR " & Format(Date, "DD-MM-YY")
'Sheets(DOTR).Range ("E2:H584").selc
Worksheets("My INT").Range("N3").Formula = "=vlookup(c3,sht,3,0)"
End Sub
Unfortunately, I get an error - "Compile Error" - Object required.
The goal is to combine several different strings into a one cohesive string:
=VLOOKUP(C3,'ABCDEF 03-08-18'!$B$4:$D$10,3,0)
That will be placed inside a cell using:
Worksheet.Range.Formula
The worksheet name "ABCDEF" is arbitrary and we create the date on the fly. We use a named range in Excel "myNamedRange" and reference the address property to allow flexibility without editing code.
Dim strSheetName As String
Dim strNamedRange As String
Dim strDateSegment As String
Dim strPrefix As String
Dim shT As String
strSheetName = "My INT"
strNamedRange = "myNamedRange"
strDateSegment = Format(Day(Date), "00") & "-" & Format(Month(Date), "00") & "-" & Right(Year(Date), 2) & "'!"
strPrefix = "'" & "ABCDEF"
shT = "=VLOOKUP(C3," & strPrefix & strDateSegment & Worksheets(strSheetName).Range(strNamedRange).Address & ",3,0)"
Worksheets("My INT").Range("N3").Formula = shT
my actual code is :
Option Explicit
Sub SaveMailActiveSheetAsPDFIn2016()
'Ron de Bruin : 1-May-2016
'Test macro to save/mail the Activesheet as pdf with ExportAsFixedFormat with Mail
Dim FileName As String
Dim FolderName As String
Dim Folderstring As String
Dim FilePathName As String
Dim strbody As String
'Check for AppleScriptTask script file that we must use to create the mail
If CheckAppleScriptTaskExcelScriptFile(ScriptFileName:="RDBMacMail.scpt") = False Then
MsgBox "Sorry the RDBMacMail.scpt is not in the correct location"
Exit Sub
End If
'My example sheet is landscape, I must attach this line
'for making the PDF also landscape, seems to default to
'xlPortait the first time you run the code
ActiveSheet.PageSetup.Orientation = xlLandscape
'Name of the folder in the Office folder
FolderName = "TempPDFFolder"
'Name of the pdf file
FileName = "Order " & [C1] & " " & Format(Date, "dd-mm-yyyy") & ".pdf"
Folderstring = CreateFolderinMacOffice2016(NameFolder:=FolderName)
FilePathName = Folderstring & Application.PathSeparator & FileName
'Create the body text in the strbody string
strbody = "Hi " & [C2] & "," & vbNewLine & vbNewLine & _
"Please find attached our new order" & vbNewLine & _
vbNewLine & _
"Thanks"
'expression A variable that represents a Workbook, Sheet, Chart, or Range object.
'Not working if you change activeworkbook, always save the activesheet
'Also the parameters are not working like in Windows
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
FilePathName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False
'Call the MacExcel2016WithMacMailPDF function to save the new pdf and create the mail
'When you use more mail addresses separate them with a ,
'Look in Mail>Preferences for the name of the mail account or signature
'Account name looks like this : "Your Name <your#mailaddress.com>"
MacExcel2016WithMacMailPDF subject:=[C6] & Format(Date, "dd/mm/yy"), _
mailbody:=strbody, _
toaddress:=[C3], _
ccaddress:=[C4], _
bccaddress:=[C5], _
attachment:=FilePathName, _
displaymail:=True, _
thesignature:="", _
thesender:=""
End Sub
I would like that all cells from E column in the print area =0 not to be displayed and that the sheet shrinks itself (like deleting the lines were =0), this before creating the .pdf document and opening mailbox.
I dunno if I'm clear enough sorry
Thank you for your help though
Assuming column E of Sheet1 is the one you want to hide if filled with zeros:
Sub hideZeroFilledColumn()
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("E:E")
rng.EntireColumn.Hidden = (Excel.WorksheetFunction.Count(rng) = _
Excel.WorksheetFunction.CountIf(rng, "0"))
End Sub
Or, if you want to hide just the lines when cell value in column E:E is 0:
Sub hideLineWithZero()
Dim WS As Worksheet
Set WS = ThisWorkbook.Worksheets("Sheet1")
Dim strColumn As String
strColumn = "E" 'If the column you want to check is "E:E"
'Getting first row of printarea and setting "rngPrintStart" to that row in column strColumn
Dim rngPrintStart As Range
'The split is used to separate the start and end of the PrintArea address
'Here we take component "0" of the split, so the start part of the PrintArea
Set rngPrintStart = Range(Split(WS.PageSetup.PrintArea, ":")(0))
Set rngPrintStart = WS.Range(strColumn & rngPrintStart.Row)
'Getting last row of printarea and setting "rngPrintEnd" to that row in column strColumn
Dim rngPrintEnd As Range
'The split is used to seperate the start and end of the PrintArea address
'Here we take component "1" of the split, so the end part of the PrintArea
Set rngPrintEnd = Range(Split(WS.PageSetup.PrintArea, ":")(1))
Set rngPrintEnd = WS.Range(strColumn & rngPrintEnd.Row)
'Merging rngPrintStart and rngPrintEnd ranges from printarea in column strColumn
Dim rngPrintColumnE As Range
Set rngPrintColumnE = WS.Range(rngPrintStart, rngPrintEnd)
Dim rng As Range
Dim rngToHide As Range
'looking in all cells from rngPrintColumnE
For Each rng In rngPrintColumnE
'checking if cell value is equal to 0 and is not empty
If (rng.Value2 = 0) And (rng.Value2 <> "") Then
'Building the range to be hidden
If rngToHide Is Nothing Then 'For the first time when "rngToHide" is not yet set
Set rngToHide = rng
Else
Set rngToHide = Union(rngToHide, rng)
End If
End If
Next rng
'to hide the rows from the previously built range
rngToHide.Rows.EntireRow.Hidden = True
End Sub
I'm assuming you want to hide column E if all the values in it are zero?
Do a sum of the values into another cell (X99 in my example) then use the following code:
With ActiveSheet
If .Range("X99").Value = 0 Then
.Range("e:e").EntireColumn.Hidden = True
Else
.Range("e:e").EntireColumn.Hidden = False
End If
End With
Edit:
You can use Abs(Min(E:E))>0 instead of Sum if you have negative values
For some reason I can't add another answer so here goes with another edit.
To hide rows that have zero in the e column:
Dim i As Integer
Dim pa As Range
Dim ecolnumber As Integer
ecolnumber = 5
Set pa = Range(ActiveSheet.PageSetup.PrintArea)
For i = 0 To pa.Rows.Count
Dim ecell As Range
Set ecell = pa(i, ecolnumber)
ecell.EntireRow.Hidden = ecell.Value = 0
Next
Note the ecolnumber, you may have to change it to reference the correct column.
After you have done all your stuff you can unhide the rows with:
For i = 0 To pa.Rows.Count
Set ecell = pa(i, ecolnumber)
ecell.EntireRow.Hidden = False
Next
I have a subroutine working just fine to export an image taken from a range in excel, but I´m facing a problem... Even when I managed to make the chart object transparent and without a border... the exported image has a lot of unused area that I wish to crop before exporting it.
Sub BtnSaveFile_Click()
Dim RgExp As Range
Dim ImageToExport As Excel.ChartObject
Const sSlash$ = "/"
Const sPicType$ = ".png"
Dim sChartName$
Dim sPath$
Dim sBook$
Set RgExp = Range("G4:N28")
RgExp.CopyPicture xlScreen, xlPicture
Set ImageToExport = ActiveSheet.ChartObjects.Add(Left:=RgExp.Left - 80, Top:=RgExp.Top - 80, Width:=RgExp.Width - 80, Height:=RgExp.Height - 80)
With ImageToExport.Chart.ChartArea.Format.Fill
.Visible = msoFalse
End With
With ImageToExport.Chart.ChartArea.Format.Line
.Visible = msoCFalse
End With
ImageToExport.Chart.Paste
Start:
sChartName = Application.InputBox("Enter A Name Of Your Choice" & vbCr & _
"There Is No Default Name Available" & vbCr & _
"The File Will Be Saved At C:\SECTIONIZER\SAVED SECTION\", "PROVIDE A NAME FOR THE VIEW", "")
If sChartName = Empty Then
MsgBox "Please Enter A File Name", , "Invalid Entry"
GoTo Start
End If
If sChartName = "False" Then
ImageToExport.Delete
Exit Sub
End If
sBook = "C:\SECTIONIZER\SAVED SECTION"
sPath = sBook & sSlash & sChartName & sPicType
ImageToExport.Chart.Export Filename:=sPath, FilterName:="PNG"
ImageToExport.Delete
ExitProc:
Application.ScreenUpdating = True
Set ImageToExport = Nothing
Set RgExp = Nothing
End Sub
I had the idea to crop it by seeking the first black pixel at each side of the image (left,top,right,bottom), so I can then set the coordinates to crop out the empty pixels, but I haven´t found a code to do so.
EDIT: added images from OP's supplied links
From this:
To this:
You will need to start the macro recorder and then crop the picture to the area of your liking, and then you can use the coordinates recorded in your subroutine. The following is a sample of what you will get
Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 196
Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 196
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 0
Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = -8
I managed to solve it. First of all, I grouped all the shapes at the excel range, with the group selected, established W and H of the selection to later attribute it to the Width and Height of the Chart to be added, then on the added chart Pasted the Copied Selection... Here is the final outcome:
Sub BtnSaveFile_Click()
Dim ImageToExport As Excel.ChartObject
Dim Shp As Shape
Dim RangeToTest As Range
Dim CC As Range
Dim DD As Range
Const sSlash$ = "/"
Const sPicType$ = ".png"
Dim sChartName$
Dim sPath$
Dim sBook$
'The images at the range are selected and grouped
Set RangeToTest = Range("G4:N28")
For Each CC In RangeToTest
Set ShpList = Sheets("SECTIONIZER").Shapes
For Each Shp In ShpList
If CC.Address = Shp.TopLeftCell.Address Then
Shp.Select Replace:=False
End If
Next Shp
Next CC
Selection.ShapeRange.Group.Select
'W and H are established with the above selected group Width and Height
W = Selection.Width
H = Selection.Height
'Selected group is copied as picture
Selection.CopyPicture xlScreen, xlPicture
'Chart Object is Added with the W and H values
Set ImageToExport = ActiveSheet.ChartObjects.Add(0, 0, W , H)
With ImageToExport.Chart.ChartArea.Format.Fill
.Visible = msoFalse
End With
With ImageToExport.Chart.ChartArea.Format.Line
.Visible = msoCFalse
End With
'Group Selected is then Pasted into the above added Chart
ImageToExport.Chart.Paste
Start:
' Pop Up Window For User To Enter File Name
sChartName = Application.InputBox("Enter A Name Of Your Choice" & vbCr & _
"There Is No Default Name Available" & vbCr & _
"The File Will Be Saved At C:\SECTIONIZER\SAVED SECTION\", "PROVIDE A NAME FOR THE VIEW", "")
' User presses "OK" without entering a name
If sChartName = Empty Then
MsgBox "Please Enter A File Name", , "Invalid Entry"
GoTo Start
End If
' If Cancel Button Is Pressed
If sChartName = "False" Then
ImageToExport.Delete
Exit Sub
End If
' If A Name Was Given, View Is Exported As A *.PNG Image
' At C:\SECTIONIZER\SAVED SECTION
sBook = "C:\SECTIONIZER\SAVED SECTION"
sPath = sBook & sSlash & sChartName & sPicType
ImageToExport.Chart.Export Filename:=sPath, FilterName:="PNG"
ImageToExport.Delete
ExitProc:
Application.ScreenUpdating = True
Set ImageToExport = Nothing
Set RgExp = Nothing
End Sub
Edit:
After doing a bit more research I stumbled on this handy little shortcut:
Just right click on the little arrows on the bottom left corner to show all sheets - no code required!
I have an excel workbook with 100 tabs. Luckily for me the tabs are all numbered 1-100. I Have an index page with all the numbers in a row and I would like to make a row next to that row with a hyperlink to the numbered tab.
A B
---------------------------
| 1 | link to tab 1 |
---------------------------
| 2 | link to tab 2 |
---------------------------
etc...
So far the most promising thing I've found is:
=Hyperlink(“C:\Documents and Settings\Admin1\Desktop\” & A1 & “.xls”,A1)
I know that the hyperlink function expects:
=HYPERLINK(link_location,friendly_name)
And when I do it manually, I get this:
=HYPERLINK('1'!$A$1,A1)
So I want to do something like this:
=HYPERLINK('& A1 &'!$A$1,A1)
But it's not working. Any help is much appreciated. Also, if there is an easier way to approach this - I am all ears.
With code something like this
Press Alt + F11 to open the Visual Basic Editor (VBE).
From the Menu, choose Insert-Module.
Paste the code into the right-hand code window.
Close the VBE, save the file if desired.
In excel-2003 go to Tools-Macro-Macros and double-click CreateTOC
In excel-2007 click the Macros button in the Code group of the Developer tab, then click CreateTOC in the list box.
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
My snippet:
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
Assumes a worksheet named 'Links"
Might not be a direct answer to your method, but I would create something more pleasing to the eye, like ... some shapes formatted nicely and then asign some basic macros to them, for selecting the sheets.
This can be easely modified to go to a specific address (like the Go TO Ctrl+Gbuilt in Excel feature).Hope this helps on the fashion style of your file :)
EDIT!
Don't know why my answer received a -1 rating. As I've said it's an alternative and not a direct solution to the given question. Still, I do believe my initial answer was superficial without a proven/working VBA code, thus I've developed a little practical example below:
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
where the "basic Select Macros" whould be:
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
Again, This is an alternative and doesn't add hyperlinks (as asked), but enables the sheet select from the same location.
TO address the buttons to links for outside files, simply define the address > filename/workbook Sheets() and Open ;)
Here is the code I use:
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