Some miscellaneous SHEET coding. been transferred from my pathname, lastcell and buildtoc pages.
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 cshtAnother method of looping through the sheets.
Sub MsgBoxAllMySheets() Dim sht As Worksheet For Each sht In Sheets MsgBox sht.name Next sht End Subor 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 SubExample 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 SubRemove 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 SubRename 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: " & mySumExamples 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
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
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.
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
Sub AddNewSheet() Dim xlSheet As Worksheet Set xlSheet = ActiveWorkbook.Sheets.Add xlSheet.Name = "My New Worksheet" Set xlSheet = Nothing End Sub
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 SubI 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.
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
Sub Macro35() ActiveWindow.ScrollColumn = ActiveCell.Column ' ActiveWindow.ScrollColumn = 1 ActiveWindow.ScrollRow = ActiveCell.Row End Sub
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
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
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
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,
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
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)
Application.Goto Reference:="sheetaa!C14"
Application.Goto Reference:=ActiveCell.Value
Application.Goto Reference:=Mid(ActiveCell.Formula, 2, i - 2)
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
A B C 1 xlindex 'xlindex'!C5 =HYPERLINK( "#" & A1 & "!C5","'" & A1 & "'!C5") 2 xlindex xlindex!C5 =HYPERLINK("#'" & A2 & "'!c5",A2 & "!C5") 3 xlindex xlindex!C5 =HYPERLINK("#xlindex!c5",A3 & "!C5") 4 xlindex C5-1 =HYPERLINK("#xlindex!c5",xlindex!C5) 5 xlindex 'xlindex'!C5 =HYPERLINK("[vlookup.xls]'" & A5 & "'!C5","'" & A5 & "'!C5") 6 xlindex xlindex =HYPERLINK("file://x:/mywebsite/davemcritchie/excel/" & A6 & ".htm",A6) 7 xlindex xlindex =HYPERLINK("http://www.mvps.org/dmcritchie/excel/" & A7 & ".htm",A7)
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")
='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?)
A | B | C | D | E | F | G | |
1 | 'h:\ | excel2k\ | [vlookup.xls] | sheet13 | '!c4 | Example | 'h:\excel2k\[vlookup.xls]sheet13'!c4 |
2 | h: | excel2k | vlookup.xls | sheet13 | C4 | Example | '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:\ | a2 | h: |
b1 | excel2k\ | b2 | excel2k |
c1 | [vlookup.xls] | c2 | vlookup.xls |
d1 | sheet13 | d2 | sheet13 |
e1 | '!c4 | e2 | C4 |
f1 | =INDIRECT(A1&B1&C1&D1&E1) | f2 | =INDIRECT("'" & A2 & "\" &B2 & "\[" &C2 & "]" &D2& "'!" &E2) |
g1 | =A1&B1&C1&D1&E1 | g2 | ="'" & A2 & "\" &B2 & "\[" &C2 & "]" &D2& "'!" &E2 |
f1= | Example | f2= | Example |
g1= | 'h:\excel2k\[vlookup.xls]sheet13'!c4 | g2= | 'h:\excel2k\[vlookup.xls]sheet13'!C4 |
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)
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")
Display | Formula |
$$ 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") |
For Each cell In Range("A1", Range("a1").End(xlDown)) Workbooks.Open (cell & ".xls") Next
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
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
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 windowI 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
'Clear the clipboard Application.CutCopyMode = False
Build Table of Contents (BuildTOC) primarily deals with documentation things.
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.