Worksheet VBA Coding

Location:   http://www.mvps.org/dmcritchie/excel/sheets.htm
Home page: http://www.mvps.org/dmcritchie/excel/excel.htm
[View without Frames]

Some miscellaneous SHEET coding.  been transferred from my pathname, lastcell and buildtoc pages.

Background information on Sheets

As a worksheet formula, created by paste special, link
    ='## 33 ##'!$A$9
characters not allowed in sheetnames  : \ ? * [ ]
Sheetnames may be up to 31 characters in length.

To use in a macro that is a single quote within double quotes

  For csht = 1 To ActiveWorkbook.Sheets.Count  'worksheet or sheets
     Cells(cRow - 1 + csht, cCol) = "'" & Sheets(csht).Name
     Cells(cRow - 1 + csht, cCol + 1) = Sheets(Sheets(csht).Name).Range("A1").Value
  Next csht
Another method of looping through the sheets.
  Sub MsgBoxAllMySheets()
    Dim sht As Worksheet
    For Each sht In Sheets
      MsgBox sht.name			
    Next sht
  End Sub
or perhaps a little more interesting, color all formula cells
  Sub AllSheetsColorFormulas()
    Dim sht As Worksheet
    For Each sht In Sheets
      On Error Resume Next 'in case no formulas
      sht.Cells.SpecialCells(xlFormulas).Interior.ColorIndex = 6
	  Next sht
  End Sub	 
Example from Dave Peterson to Build an array of sheetnames, 2001-06-02
   Sub ARRAY_sheetnames()
   Dim wksht As Worksheet
   Dim i As Long
         Dim wkshtnames()     'This is an array definition
    i = 0
    For Each wksht In ActiveWorkbook.Worksheets
        i = i + 1
        ReDim Preserve wkshtnames(1 To i)
        wkshtnames(i) = wksht.Name
    Next wksht

    For i = LBound(wkshtnames) To UBound(wkshtnames)
        MsgBox wkshtnames(i)
    Next i
        End Sub
Remove ALL commas from text constants in all workbooks.  Warning watch out for CSV file type data.
  Option Explicit
  Sub WsReplaceLooseCommas()
     Dim ws As Worksheet
      For Each ws In ActiveWorkbook.Worksheets
      ws.Cells.SpecialCells(xlCellTypeConstants, 2). _
         Replace What:=",", Replacement:=" ", LookAt:=xlPart, _
          SearchOrder:=xlByRows, MatchCase:=False
      Next ws
  End Sub
Rename a sheet to one ending with single quote followed by double quote
      Sheets("##33##").Name = "## 33 $$'"""
Run an application: (no sheet here)
      mySum = Application.Run("MYCUSTOM.XLM!My_Func_Sum", 1, 5)
      MsgBox "Macro result: " & mySum
Examples of assigning a sheetname - leading zeros can be tricky
      ActiveSheet.Name = "01343"
      ActiveSheet.Name = Format(123, "0000")
      ActiveSheet.Name = "04-03-2001"
      ActiveSheet.Name = Format(Date, "mm-dd-yyyy")
      ActiveSheet.Name = Format(Date, "yyyy-mm-dd")
      ActiveSheet.Name = target.Text

Some Sheet related coding

Sub Macro29()

'Create a New Workbook containing only one sheet
                Workbooks.Add xlWorksheet
                set newwb = workbooks.add(1)
                set newwb = Workbooks.Add(xlWBATWorksheet)

'Create New Sheet
    Sheets.Add
'Rename current Sheet
    ActiveSheet.Name = "Renamed14a"
    ActiveSheet.Name = "D" & Format(Date, "yyyymmdd")
    ActiveSheet.Name = "D" & Format(Range("a1"), "yyyymmdd")
'Activate a Sheet (what is difference activate/select)
    Sheets("Sheet14").Activate
'Select a Sheet, actually may be current sheet
    Sheets("Sheet14").Select
'Rename a Sheet, actually may be current sheet
    Sheets("Sheet14").Name = "Renamed14"
'Select an Existing Sheet
    Sheets("Map").Select
'Obtain sheetname and codename of current sheet
    msgbos activesheet.name & " codenam is " & activesheet.codename
'Create a copy of current sheet,  just before current sheet
    ActiveSheet.Copy Before:=ActiveSheet
'Copy the latest sheet
    Sheets(ActiveWorkbook.Sheets.Count).Select
    ActiveSheet.Copy after:=ActiveSheet
'Select all cells on a worksheet
    cells.Select
'Select all cells on a worksheet within the used range
    ActiveSheet.UsedRange.Select
'Process all cells on a workshet within used range with text constants
    For Each cell In Cells.SpecialCells(xlConstants, xlTextValues)
         cell.Value = CDbl(cell.Value)
    Next cell
'Select an area within a worksheet
    set rng = Application.Inputbox("Select range",Type:=8)
'Select an area within a macro, with current selection as default
    Set Rng = InputBox("Select range", "TITLE1", Selection.Address(0, 0))
'Select an area within a worksheet, default current selection, redo with cursor
    Dim Rng As Range
    Set Rng = Application.InputBox("Select range", "TITLE1", _
       Selection.Address(0, 0), Type:=8)
    MsgBox Rng.Address(0, 0)
    Rng.select
    'It is seldom necessary to change the selection within a macro
    'the selection would be changed because you to see it, but the
    'macro could work with Range(Rng) just as easily as selection.range


End Sub

Number of pages to be printed

Thought I'd include this specifically from a posting by Eric Desart since there was some question as to codeing.
NumPages1 = ExecuteExcel4Macro("Get.document(50,"")")
Does Not work = gives Error

NumPages2 = ExecuteExcel4Macro("Get.document(50)")
Returns number of pages to be printed of active sheet.

NumPages3 = ExecuteExcel4Macro("Get.document(50,""Sheet2"")")
Returns number of pages to be printed of Sheet 2 even if not active.

NumPages4 = ExecuteExcel4Macro("Get.document(50,""[TEST.XLS]Sheet3"")")
Returns number of pages to be printed of File TEST.XLS Sheet 3 even if
not active.

Check for Existence of a Sheet before creating

The following came from a posting by Chip Pearson 23Oct1999 in programming.
Function WorksheetExists(WSName As String) As Boolean
    On Error Resume Next
    WorksheetExists = Len(Worksheets(WSName).Name) > 0
End Function

Then, in your code,

If WorksheetExists("Summary") = True Then
    MainMacro
Else
    CreateSummarySheet
End If

Naming NEW sheets

Code posted in programming group by David Phillips 2000-06-12, setting value to Nothing is a memory issue.
Sub AddNewSheet()
   Dim xlSheet As Worksheet
   Set xlSheet = ActiveWorkbook.Sheets.Add
   xlSheet.Name = "My New Worksheet"
   Set xlSheet = Nothing
End Sub

Cycling through sheets looking for specific value in cell A1

Sub MatchWStoA1()
 '//  Find cell A1 that contains  Customer Name
 '//  David McRitchie   2000-07-15 programming for L.Wong
  Dim cn As String, cn2 As String, ws As Worksheet
  cn = InputBox("Enter customer name, as found in cell A1")
retry:
  If cn = "" Then Exit Sub
  cn = Trim(LCase(cn))
  Dim cn3 As String
  cn3 = cn
  For Each ws In ActiveWorkbook.Sheets
     cn2 = Trim(LCase(Sheets(ws.Name).Range("A1").Value))
     cn2 = Replace(cn2, Chr(160), "")
     If cn2 = cn Then         'HELP, Working with Active Cell
        Worksheets(ws.Name).Activate    'must do this first
        Worksheets(ws.Name).Range("A1").Activate
        Exit Sub
     End If
  Next ws
  cn = InputBox(cn & " -- Not Found" & Chr(10) & _
         "REENTER Customer name, or hit [Cancel]")
  GoTo retry
End Sub
I also included this comment.

I think this is going to drive people crazy why not rename the sheets with the customer name or at least build a table of contents with information. See my buildtoc.htm page all you need to do is add content of cell A1 from each sheet. You will also find information there for sorting sheetnames.

Scroll for position in window of active cell

Display Cell A1 in upper left corner of sheet

The following was to protect sheet from accidentally deleting any data in the active range.
  Sub Macro35()
    'Select cell without data and display top left corner of sheet
    'Dim lastrow As Integer
    'lastrow = Cells.SpecialCells(xlLastCell).Row
    'Range(Cells(lastrow + 1, 1), Cells(lastrow + 1, 1)).Select
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
  End Sub

Display Active cell in upper left corner of sheet

  Sub Macro35()
    ActiveWindow.ScrollColumn = ActiveCell.Column
    ' ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = ActiveCell.Row
  End Sub

Navigations within a sheet based on another sheet

The following would use another sheet with the address to navigate to.

Note both A23 and A24 refer back to G23, so you cannot write a program directly reversible as where to go backwards in the macro from G23.

Sheet24_Nav
A23:  =Sheet24!G23
G23:  =Sheet24!A23
A24:  =Sheet24!G23



Sheet24
select  C23  and run macro, goes to next cell because
    no formula in sheet24_nav!C23
select  A23  and run macro,  goes to G23, because
    sheet24_nav!A23 contains formula  =Sheet24!G23

Sub NavigateToFormulaOn_Nav()
    Dim sFormula As String
    On Error GoTo notgood
    sFormula = Worksheets(ActiveSheet.Name & "_nav"). _
         Range(ActiveCell.Address).Formula
    If Left(sFormula & " ", 1) <> "=" Then GoTo notgood
    Range(Mid(sFormula, 2)).Activate
    Exit Sub
notgood:
    ActiveCell.Offset(0, 1).Activate
End Sub

Some Loops through Worksheets

These are example only, the msgbox will sort of fail on you if you have many sheets,

The LoopThru which resembles your original will reach a limit on characters in the msgbox -- limit varies by version.

The LoopSheet will fail to show all sheets because due to limit or failure to be able to show another box after the first fills up the monitor window.

More useful examples can be found in
Build Table of Contents and optionally sort worksheets
http://www.mvps.org/dmcritchie/excel/buildtoc.htm


Option Explicit
Public Sub LoopThru()
Dim mostofthem As String
Dim sheet As Variant
For Each sheet In ActiveWorkbook.Sheets
    mostofthem = mostofthem & sheet.Name & ", "
Next sheet
MsgBox mostofthem
End Sub

Public Sub LoopSheets()
  Application.Calculation = xlManual   'xl97 up use xlCalculationManual
  Application.ScreenUpdating = False
  Dim mostofthem As String
  Dim csht As Integer
  mostofthem = ""
  For csht = 1 To ActiveWorkbook.Sheets.Count  'worksheet or sheets
     mostofthem = mostofthem & Sheets(csht).Name & Chr(10)
  Next csht
  MsgBox mostofthem, , "names of sheets"
  Application.ScreenUpdating = True
  Application.Calculation = xlAutomatic   'xl97 up use xlCalculationAutomatic
End Sub

Public Sub LoopShorter()
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        MsgBox ws.Name
        '   ws.Protect password:="AnyThing"
    Next ws
End Sub

 Sub Martin002()
     'place 'Martin 0'!A1 value into distinct sheets
     Dim x As Variant
     Dim sht As Variant
     x = Array("Martin 1", "Sheet2", "MSFT")
     Sheets("Martin 0").Activate
     For Each sht In x
       Sheets(sht).PageSetup.LeftHeader = ActiveSheet.Cells(1, 1)
     Next sht
 End Sub

Rename Sheet

 Sub RSHEET()
   'Rename Sheet,  D.McRitchie, 2001-04-05 programming
     Dim xStr As String
retry:
     Err.Clear
     xStr = InputBox("Supply new name for old sheet,  blah," _
       & "blah,blah", "Rename Sheet", ActiveSheet.Name)
     If xStr = "" Then Exit Sub
     On Error Resume Next
     ActiveSheet.Name = xStr
     If Err.Number <> 0 Then
        MsgBox Err.Number & " " & Err.Description
        Err.Clear
        GoTo retry
     End If
     On Error GoTo 0
     '... continue......
 End Sub

Delete Active Sheet if name begins with "sheet" DelSht - Delete Sheet

To help quikcly clean up some testing.  Will delete sheets with names beginning "sheet" without verification.  Other sheets will be deleted only when you reply to the normal message. 

An exception for sheets with program code -- they will not be deleted nor will you be asked if you want to delete them. 

I have buttons to go through the sheet tabs, Previous Sheet  Next Sheet  navigating to the Previous and Next sheets as described in BuildTOC, but you can use Ctrl+PageUP (to left) and Ctrl+PageDN (to right)

Sub DeleteThisSheet()
   Dim ans As Variant
   Dim saveTrue As Variant
   Dim sheetcodelines As Long
   '--requires ref. to the MS VBA Extensibility' library
   sheetcodelines = ActiveWorkbook.VBProject.VBComponents _
         (ActiveSheet.CodeName).CodeModule.CountOfLines
   If sheetcodelines > 2 Then
      MsgBox ActiveSheet.Name & " -- has " & _
         sheetcodelines & " lines of code (not deleted) "
   ElseIf Left(ActiveSheet.Name, 5) = "Sheet" Then
      Application.DisplayAlerts = False
      ActiveSheet.Delete
      'tflush_wav
      Application.DisplayAlerts = True
   Else
      Application.DisplayAlerts = True
      ActiveSheet.Delete
   End If
End Sub

Linked files in Excel

The first line is the way a link displays,
the second line is how you might type it in
the third line is how you might code the line for use in INDIRECT
the fourth line invokes a user defined function (UDF)
 D:\myfolder\excel\TAXES\myfile.xls - checking!B600
 d:\myfolder\excel\taxes\myfile.xls[checking]!b600
 ="d:\myfolder\excel\taxes\" & A14 & "["& A15 & "]!"&"b600"
 =myfile.xls!getformula(B2)

VBA gotocell

Similar VBA code is used to goto a cell (see BuildTOC), go to a macro (see GoToCell).
 Application.Goto Reference:="sheetaa!C14"

VBA goto subroutine/macro/function

See GoToSub

Application.Goto Reference:=ActiveCell.Value

Application.Goto Reference:=Mid(ActiveCell.Formula, 2, i - 2)

Coding a link address and friendly name using HYPERLINK Worksheet function

This topic was copied from buildtoc.htm, where additional similar information can be found, including information on how to display hyperlink information.
Worksheet code that created a hyperlink
=HYPERLINK("h:\excel2k\testng2k.xls#sheet3!a1","SHEET3")
=HYPERLINK("[h:\excel2k\testng2k.xls]sheet3!a1","SHEET3")
=HYPERLINK("[d:test\test.xls]test!b5","thisone good b5")
=HYPERLINK("d:\website\dmcritchie","dmcr")
=HYPERLINK("d:test\test.xls","thisone is also good")
=HYPERLINK("[testng2k.xls]'$$TOC'!A56","heidi-ho $$TOC!A56")
=HYPERLINK("[h:\excel2k\testng2k.xls]'$$TOC'!a3","text in a3 in $$TOC")
=HYPERLINK("[file:\\\d:test\test.xls]test!B3","thisone is good")
=HYPERLINK("[http://www.business.com/report/budget report.xls]Annual!F10","Report")
=HYPERLINK("[http://www.mvps.org/dmcritchie/excel/excel.htm]","My Excel Pages")
=HYPERLINK("file:\\\c:\temp\David McRitchie\a.txt","thisone is good")
=HYPERLINK("mailto:DMcRitchie@msn.com","David McRitchie")
It appears that even if the link is to a cell in the same worksheet you must include the bookname including .XLS extension, as well as the sheetname.

  =HYPERLINK("[WBName.xls]Michael!A5", "Michael I")

xlindex.htm is a sheet on my page, on my HD and on my website xlindex is also a sheet in my vlookup.xls file the following examples show Column B what you see, Col C is the formula, and "C5-1" is the value in cell c5 on sheet xlindex

 ABC
1xlindex  'xlindex'!C5 =HYPERLINK( "#" & A1 & "!C5","'" & A1 & "'!C5")
2xlindex xlindex!C5 =HYPERLINK("#'" & A2 & "'!c5",A2 & "!C5")
3xlindex xlindex!C5 =HYPERLINK("#xlindex!c5",A3 & "!C5")
4xlindex C5-1 =HYPERLINK("#xlindex!c5",xlindex!C5)
5xlindex 'xlindex'!C5 =HYPERLINK("[vlookup.xls]'" & A5 & "'!C5","'" & A5 & "'!C5")
6xlindex xlindex =HYPERLINK("file://x:/mywebsite/davemcritchie/excel/" & A6 & ".htm",A6)
7xlindex xlindex =HYPERLINK("http://www.mvps.org/dmcritchie/excel/" & A7 & ".htm",A7) 

Using HYPERLINK Worksheet Function where workbook name can change

As aready mentioned you must include the filename, even if it refers to a cell in the same workbook.  You can use this code to generate the workbook name.  As mentioned on my Pathname page you must include the cell reference to get a valid result from the CELL Worksheet Function. 

B3:  =MID(CELL("filename",A1),FIND("[",CELL("filename",A1),1)+1,FIND("]",CELL("filename",A1),1)-FIND("[",CELL("filename",A1),1)-1)

and use it as follows:
A1:  =HYPERLINK("["&hyperlink!$B$3 & "]'Sheet One'!A1","Sheet One")

Some Worksheet Examples using INDIRECT

   ='Worksheet 1'!G3
   =INDIRECT("Worksheet 1'" & "!" & "G3")
   =INDIRECT("'Worksheet 1'" & "!G" & h4)
   =INDIRECT("'c:\My Documents\[WTA " & Year(Now())-1 & ".xls]Sheet1'!$B$4")
The above is hard to read, single quotes surround the worksheet name because it includes a blank. All the rest are double quotes.

INDIRECT will not work for closed files.

Extended one step further using the sheetname in cell A1:

   =INDIRECT("'" & A1 & "'" & "!" & "G" & H4)
which now includes a single quote within double quotes around the sheetname specified in cell A1. You can simplify the formulas by combining text together in all of the above (hope you can read it).
   =INDIRECT("'" & A1 & "'!G" & H4)
Additional examples involving replication can be found on my Fill Handles page.
   =LARGE($A$1:$A$10,ROW(1:1))

INDIRECT to refer to a cell in another workbook (actually used same workbook, can you tell?)
 ABCDEFG
1'h:\excel2k\ [vlookup.xls]sheet13'!c4 Example'h:\excel2k\[vlookup.xls]sheet13'!c4
2h:excel2kvlookup.xls sheet13C4Example 'h:\excel2k\[vlookup.xls]sheet13'!C4
3        
4   Example     

Note cell A1 and E1 show a single quote but you must type in an additional single quote before the one you see.
A1 =getformula(INDIRECT(A7))   
A1'h:\a2h:
b1excel2k\b2excel2k
c1[vlookup.xls]c2 vlookup.xls
d1sheet13d2sheet13
e1'!c4e2C4
f1=INDIRECT(A1&B1&C1&D1&E1)f2 =INDIRECT("'" & A2 & "\" &B2 & "\[" &C2 & "]" &D2& "'!" &E2)
g1=A1&B1&C1&D1&E1g2 ="'" & A2 & "\" &B2 & "\[" &C2 & "]" &D2& "'!" &E2
f1=Example f2=Example
g1='h:\excel2k\[vlookup.xls]sheet13'!c4 g2='h:\excel2k\[vlookup.xls]sheet13'!C4

Last sheet Created

The last sheet created can be identified in VBA from it's Worksheet Count.  Norman Harker 2001-06-12))
     LastSheetName = Worksheet(Worksheets.Count))
The last sheet updated can be identified with the crippled  =CELL("Filename") until a recalcuation occurs, but that is a very unstable form and I expect it is related to serious problems.  There is no problem with =CELL("filenname",A1)

Referencing a Relative Worksheet Name in a Workbook

The following formula will obtain the sheetname in the current workbook.
Function RelSheet(sht As Long) As String
  RelSheet = Worksheets(sht).Name
End Function

Function WB_Sheet_cell(wb As String, sht As Long, cell As String) As String
  WB_Sheet_cell = Workbooks(wb).Worksheets(sht).Range(cell)
End Function
  =wb_sheet_cell("MP1.xls",1,"$A$2")
 where   MP1.xls   is your other workbook
 where   1   is the relative worksheet number
 where   $A$2   is the cell in the other workbook's relative sheet 1.

DisplayFormula
$$ TOC=relsheet(1)
'$$ TOC'!b2 ="'" & relsheet(1)&"'"&"!b2"
Type =INDIRECT("'" & relsheet(1)&"'"&"!b2")
Type =wb_sheet_cell("martin_hyperlinks.xls",1,"b2")
C:\temp\[martin_hyperlinks.xls]Sheet20 =CELL("filename",A1)
#VALUE! =wb_sheet_cell(CELL("filename",A1),1,"b2")
Type =wb_sheet_cell(MID(CELL("filename",A1),FIND("[",CELL("filename",A1),1)+1,FIND("]",CELL("filename",A1),1)-FIND("[",CELL("filename",A1),1)-1),1,"b2")

HTML HREF=

nothing yet.

Workbook

This webpage is for sheet coding, but here is some code for workbooks.

Open a workbook from named in cells

Open workbooks in current range down from A1.
For Each cell In Range("A1", Range("a1").End(xlDown))
    Workbooks.Open (cell & ".xls")
Next

List the names of the open workbooks

...placeholder...

Create folder and save file

The following will create a folder from the value in C3 on Sheet1 and save the file, by the same name in that folder. It will ignore a folder already being in existence, but will warn you if a file in there with the same name is about to be overwritten
Sub CreateFolderAndSaveFile()
'Nick Hodge, 2000-06-12 microsoft.public.excel.worksheet.functions
Dim fName As String
On Error Resume Next
fName = ThisWorkbook.Worksheets("Sheet1").Range("C3").Value
MkDir ("C:\Projects\" & fName & "\")
ChDir ("C:\Projects\" & fName & "\")
ThisWorkbook.SaveAs Filename:=fName
End Sub

Generate Sheets with sheetnames named from current selection of cells

Set up to generate sheetnames for dates, but easily changed to just do constants with   activesheet.name=cell.text   as needed.
Sub genWStabnames()
    Dim cell As Range
    Dim newName As String, xx As String
    Err.Description = ""
    On Error Resume Next
    For Each cell In Selection
       Worksheets.Add
       If Err.Description <> "" Then Exit Sub
       MsgBox Format(cell.Value, "yyyy-mm-dd")
       Err.Description = ""
       newName = Format(cell.Value, "yyyy-mm-dd")
       ActiveSheet.Name = newName
       If Err.Description <> "" Then
          '--failed to rename, probably sheetname already exists...
          xx = MsgBox("Failed to rename inserted worksheet " & _
           vbLf & _
           ActiveSheet.Name & " to " & newName & vbLf & _
           Err.Number & " " & Err.Description, vbOKCancel, _
           "Failure to Rename Worksheet:")
          '--eliminate already created sheet that was to be renamed...
          Application.DisplayAlerts = False
          ActiveSheet.Delete
          Application.DisplayAlerts = True
          '--check for immediae cancellation...
          If xx = vbCancel Then Exit Sub
          Err.Description = ""
       End If
    Next cell
End Sub

Miscellaneous

The following is just some code that I did not want to lose track of:

And if the macro is exited with any of these things in effect is there any way of telling what's wrong or just resetting it,

    Application.Interactive = False      'prevents user interference with the macro
    Application.DisplayAlerts = False  'suppress prompts and alerts
    Application.ScreenUpdating = False  'suppress screen repainting
    ActiveWindow.Visible = False     'hides the active window
I thought the following would put things back to normal, but after rereading the switches, I don't think it would change. I turned off macros and fixed the interactive once, but more interested in if you don't know what happened.

"C:\Program Files\Microsoft Office\Office\Excel.exe" /regserver change path as needed or just use Excel.exe /regserver

Q211481 - XL2000: Startup Switches for Microsoft Excel 2000
  http://support.microsoft.com/support/kb/articles/Q211/4/81.ASP
Q159474 - XL97: Startup Switches for Microsoft Excel 97
  http://support.microsoft.com/support/kb/articles/Q159/4/74.asp

Misc other short things

'Clear the clipboard
    Application.CutCopyMode = False

Related Examples

Cells, Cells related coding

Build Table of Contents (BuildTOC) primarily deals with documentation things.

PathName Slow Response

Related Information on other sites


You are one of many distinguished visitors who have visited my site here or in a previous location  since created on Oct 22, 1999.  Return to TOP.

 

Visit [my Excel home page]   [Index page]   [Excel Onsite Search]   [top of this page]

Please send your comments concerning this web page to:  David McRitchie  mailto:DMcRitchie@msn.com