How can I loop through a subset of worksheets? - excel

I know how to loop through all the worksheets in a workbook, and how to exit once I reach an 'end-flag' worksheet:
For Each ThisWorkSheet In Worksheets
If ThisWorkSheet.Name = "FlagEnd" Then Exit For
MsgBox "This worksheet name is: " & ThisWorkSheet.Name
Next
However I cannot get the loop to begin on a 'start-flag' worksheet (or even better on the worksheet right after the start-flag worksheet. For example the flagged start/end worksheets are in the middle of a bunch of other worksheets, so beginning or end traversing is not workable.
There could be hundreds of worksheets before that 'FlagStart' sheet, so I really need to start on the right sheet.
Tried:
Set ThisWorkSheet = Sheets("FlagNew")
and
For Each Sheets("FlagNew") In Worksheets
Ideas?
Solution:
Mathias was very close, but dendarii was that tiny step closer with the custom ending index. I actually figured out my final solution on my own, but wanted to give credit. Here was my final solution:
Private Sub CommandButtonLoopThruFlaggedSheets_Click()
' determine current bounds
Dim StartIndex, EndIndex, LoopIndex As Integer
StartIndex = Sheets("FlagNew").Index + 1
EndIndex = Sheets("FlagEnd").Index - 1
For LoopIndex = StartIndex To EndIndex
MsgBox "this worksheet is: " & Sheets(LoopIndex).Name
' code here
Next LoopIndex
End Sub

If this is not a particularly changeable workbook (i.e. worksheets are not being added and deleted all the time), you could store the names of the worksheets in a range on a hidden sheet and loop through them by name.
However, it sounds like they are stored consecutively in the workbook so, building on Mathias' solution, you could use a function to return the indices of the start and end worksheets and then loop through:
Public Function GetStartIndex() As Integer
On Error Resume Next
GetStartIndex = ThisWorkbook.Worksheets("MyStartingWorksheet").Index + 1
End Function
Public Function GetEndIndex() As Integer
On Error Resume Next
GetEndIndex = ThisWorkbook.Worksheets("MyEndingWorksheet").Index - 1
End Function
Sub LoopThrough()
Dim wks As Worksheet
Dim i As Integer
Dim iStart As Integer
Dim iEnd As Integer
iStart = GetStartIndex()
iEnd = GetEndIndex()
If iStart > 0 And iEnd > 0 And iEnd > iStart Then
For i = iStart To iEnd
Set wks = ThisWorkbook.Worksheets(i)
MsgBox wks.Name
Next i
End If
End Sub

I believe that if you use "foreach" you won't have any control over the starting sheet. For that matter, I am not even sure you are guaranteed the order in which the iteration will take place.
I think what you should do is first, get the index of the sheet you are interested in (get the sheet by name, and get its index), and then iterate using a for loop, over the indexes of the sheets starting at the flag sheet index.
[Edit: I hacked through a quick example]
Sub Iterate()
Dim book As Workbook
Dim flagIndex As Integer
Dim flagSheet As Worksheet
Set book = ActiveWorkbook
Set flagSheet = book.Worksheets("Sheet3")
flagIndex = flagSheet.Index
Dim sheetIndex As Integer
Dim currentSheet As Worksheet
For sheetIndex = flagIndex To book.Worksheets.Count
Set currentSheet = book.Worksheets(sheetIndex)
Next
End Sub

How about?
For Each ThisWorkSheet In Worksheets
If ThisWorkSheet.Name = "FlagStart" Then output = true
If ThisWorkSheet.Name = "FlagEnd" Then Exit For
If output = true Then MsgBox "This worksheet name is: " & ThisWorkSheet.Name
Next
This code might not be quite right. I'm writing it in the SO editor not VBA, but you get the idea.

Do the sheets you iterate over have a common name format?
Ex)
Sheets(0).name > "Reports"
Sheets(1).name > "Start Here"
Sheets(2).name > "emp.0001"
Sheets(3).name > "emp.0002"
Sheets(4).name > "emp.0003"
Sheets(5).name > "emp.0004"
Sheets(6).name > "End Here"
If so, in your for each loop, just do a Left(ThisWorkSheet.name, 4) = "emp" to verify if it's a sheet you want to reference.

In Excel VBA 2013 if you have the worksheets you want to update between tabs "Blankfirst" and "Blanklast" this works.
Use the code below to test it brings back your tab names and then replace your manipulating code in place of MsgBox wks.Name part.
Sub Macro2()
On Error Resume Next
GetStartIndex = ThisWorkbook.Worksheets("Blankfirst").Index + 1
On Error Resume Next
GetEndIndex = ThisWorkbook.Worksheets("Blanklast").Index - 1
Dim wks As Worksheet
Dim i As Integer
Dim iStart As Integer
Dim iEnd As Integer
iStart = GetStartIndex
iEnd = GetEndIndex
If iStart > 0 And iEnd > 0 And iEnd > iStart Then
For i = iStart To iEnd
Set wks = ThisWorkbook.Worksheets(i)
MsgBox wks.Name
Next i
End If
End Sub

Public Sub ITERATE_WORKSHEETS()
On Error Resume Next
Dim x As Long
For x = 0 To 100
MsgBox Worksheets(x).Name
Next x
On Error GoTo 0
MsgBox "all done"
End Sub

Related

Validate if sheet exists before deleting

I have the following code where I want to delete the sheets, I noticed that if they do not exist I get an error, how can I validate and delete only if they exist?
I also noticed I get a deleting warning for every single sheet, any way I can prevent from seeing that warning?
Sub delete_hours()
Worksheets("8am").Delete
Worksheets("9am").Delete
Worksheets("10am").Delete
Worksheets("11am").Delete
Worksheets("12pm").Delete
Worksheets("1pm").Delete
Worksheets("2pm").Delete
Worksheets("3pm").Delete
Worksheets("4pm").Delete
Worksheets("5pm").Delete
Worksheets("6pm").Delete
End Sub
if you find a better way to do this let me know.
Thanks all,
Delete Existing Worksheets
You need the first three procedures: TESTdeleteWorksheetsFromList calls deleteWorksheetsFromList which calls getWorksheetNames.
TESTgetWorksheetNames just tests getWorksheetNames.
It surely can be done much simpler, but I had this idea...
The Flow (deleteWorksheetsFromList)
The values from the DeleteList are written to the delNames array.
All worksheet names are written to the allNames array.
Application.Match is 'applied' to both arrays resulting in Matches array.
Matches array is looped through to write 'matches' to the 'beginning' of delNames array.
delNames array is resized to the number of found matches.
delNames array is used to delete the worksheets in one go.
The Code
Option Explicit
Sub TESTdeleteWorksheetsFromList()
Const DeleteList As String _
= "8am,9am,10am,11am,12pm,1pm,2pm,3pm,4pm,5pm,6pm"
Dim wb As Workbook: Set wb = ThisWorkbook
deleteWorksheetsFromList wb, DeleteList
End Sub
Sub deleteWorksheetsFromList( _
wb As Workbook, _
ByVal DeleteList As String, _
Optional ByVal Delimiter As String = ",")
Dim delNames() As String: delNames = Split(DeleteList, Delimiter)
Dim allNames() As String: allNames = getWorksheetNames(wb)
Dim Matches As Variant: Matches = Application.Match(allNames, delNames, 0)
Dim i As Long
Dim k As Long
For i = 1 To UBound(Matches)
If IsNumeric(Matches(i)) Then
delNames(k) = delNames(Matches(i) - 1)
k = k + 1
End If
Next i
If k > 0 And k < wb.Sheets.Count Then
ReDim Preserve delNames(0 To k - 1)
Application.DisplayAlerts = False
wb.Worksheets(delNames).Delete
Application.DisplayAlerts = False
End If
End Sub
Function getWorksheetNames(wb As Workbook) As Variant
Dim wsCount As Long
wsCount = wb.Worksheets.Count
If wsCount > 0 Then
Dim wsNames() As String
ReDim wsNames(0 To wsCount - 1)
Dim ws As Worksheet
Dim n As Long
For Each ws In wb.Worksheets
wsNames(n) = ws.Name
n = n + 1
Next ws
getWorksheetNames = wsNames
End If
End Function
Sub TESTgetWorksheetNames()
Debug.Print Join(getWorksheetNames(ThisWorkbook), vbLf)
End Sub
You can use the following code prior to attempting deletions:
On Error Resume Next
When you are done:
On Error goto 0
That's the quick and dirty solution. You should also use a loop instead of repeating the same code:
for i=8 to 12
sheetname = i & "am"
sheets.delete(sheetname)
next

Table refresh vba excel Call procedure from another procedure Error Code 1004

I have a call procedure to clear contents of tables across multiple worksheets.
This procedure is invoked only from the 2nd sheet of the workbook. When I invoke this, I am getting Error 1004 "Application-defined or Object-defined error".
Below is the parent code base invoking the sub procedure:
Sub ValidateData_BDV1()
On Error Resume Next
Err.Clear
'''''Define Variables'''''''''
Dim mySheet As Worksheet
Dim mySheetName As String
Dim bdvName As Variant
Dim sqlQuery As String
Dim connectStr As String
Dim wsMatch As Worksheet
Dim myWorkbook As Workbook: Set myWorkbook = ThisWorkbook
'''''''''Set Variables''''''''
cancelEvent = False
Set mySheet = ActiveSheet 'Sets mySheet variable as current active sheet
mySheetName = mySheet.Name
driverName = mySheet.Range("B1").Value2 'Get the value of the TDV driver
' MsgBox driver
dataSourceName = mySheet.Range("B3").Value2 'Get the data source name for the published TDV database
' MsgBox dataSourceName
schemaName = mySheet.Range("B5").Value2 'Get the schema name of the published tdv view
bdvName = mySheet.Range("B6").Value2 'Get the name of the published BDV
''''''''''Refresh data across sheets'''''''''''''
Application.ScreenUpdating = False 'Prevent screen flickering while doing the refresh
'''''''''''''''''''''''''''''''''''''''
''''''''''''Call sub procedure'''''''''
Call ClearTableContents
''''''''''''''''''''''''''''''''''''
mySheet.Activate
Application.ScreenUpdating = True 'Prevent screen flickering while doing the refresh
''''''''Show User id and Password box'''''''''
If Len(Uid) < 1 Or Len(Password) < 1 Then
UserForm1.Show
End If
If (cancelEvent = True) Then
Exit Sub
End If
............
............perform some task with error handling
Below is the code base of the called Sub
Sub ClearTableContents()
Dim wrksht As Worksheet
Dim objListObj As ListObjects
Dim tableName As String
Dim ActiveTable As ListObject
Dim rowCount As Integer
Dim colCount As Integer
Dim i As Integer
Dim j As Integer
'''''Iterate through the Bdv1, bdv2 and Match sheets. Set default table sizes for each
sheet'''''''''
For j = 2 To 4
If (j = 2) Or (j = 3) Then
rowCount = 5
colCount = 6
ElseIf (j = 4) Then
rowCount = 5
colCount = 9
End If
Application.ScreenUpdating = False 'Prevent screen flickering while doing the refresh
Set wrksht = ActiveWorkbook.Worksheets(j)
Set objListObj = wrksht.ListObjects 'Get list of tables objects from the current sheet
'''''''Iterate through the tables in the active worksheet''''''''''''''
For i = 1 To objListObj.Count
tableName = objListObj(i).Name
Set ActiveTable = wrksht.ListObjects(tableName)
On Error Resume Next
''''''For each table clear the contents and resize the table to default settings''''''''''''
With wrksht.ListObjects(i)
.DataBodyRange.Rows.Clear
.Range.Rows(rowCount & ":" & .Range.Rows.Count).Delete
.HeaderRowRange.Rows.ClearContents
.HeaderRowRange.Rows.Clear
.Range.Columns(colCount & ":" & .Range.Columns.Count).Delete
.Resize .Range.Resize(rowCount, colCount)
End With
wrksht.Columns("A:Z").AutoFit
Next i
Next j
ThisWorkbook.Worksheets(2).Activate '''set the active sheet to the sheet number 2
Application.ScreenUpdating = True 'Prevent screen flickering while doing the refresh
Exit Sub
'Error Handling
NoTableSelected:
MsgBox "There is no Table currently selected!", vbCritical
End Sub
Please help in resolving the issue.
If I execute as independent macro on click of the button, it works perfectly well.
I am going to post this as an "answer", since I think it may at least help, if not solve, your issue.
Clearing tables (list objects) via VBA code can be a little tricky, and I learned this hard way. I developed and have been using the below function for quite some time and it works like a charm. There are comments to explain the code in the function.
Sub clearTable(whichTable As ListObject)
With whichTable.DataBodyRange
'to trap for the bug where using 'xlCellTypeConstants' against a table with only 1 row and column will select all constants on the worksheet - can't explain more than that its a bug i noticed and so did others online
If .rows.count = 1 And .columns.count = 1 Then
If Not .Cells(1, 1).HasFormula Then .Cells(1, 1).ClearContents
Else
'my tables often have formulas that i don't want erased, but you can remove if needed
On Error Resume Next
.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End If
'remove extra rows so table starts clean
Dim rowCount As Long
rowCount = .rows.count
If rowCount > 1 Then .rows("2:" & rowCount).Delete 'because you can't delete the first row of the table. it will always have 1 row
End With
End Sub
Call the procedure like this:
Dim lo as ListObject
For each lo in Worksheets(1).ListObjects
clearTable lo
next
Commented line to make my code work
.Range.Columns(colCount & ":" &
.Range.Columns.Count).Delete

Detect the renaming or deletion of worksheets

Is there a way to detect when a user
renames, or
deletes a worksheet?
I want to run some code if one of these events happens.
what I have tried
My tool uses a lot of event handlers so one thing I thought of was looping through all the sheetnames during each Worksheet_Change, but I don't think that is the best approach.
This approach goes under the ThisWorkbook module.
Public shArray1 As Variant
Public shArray2 As Variant
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Dim lngCnt As Long
Dim strMsg As String
Dim strSht
Dim vErr
Dim strOut As String
'get all sheet names efficiently in a 1D array
ActiveWorkbook.Names.Add "shtNames", "=RIGHT(GET.WORKBOOK(1),LEN(GET.WORKBOOK(1))-FIND(""]"",GET.WORKBOOK(1)))"
shArray2 = Application.Transpose([INDEX(shtNames,)])
strSht = Application.Transpose(Application.Index(shArray2, , 1))
'exit here if first time code is run
If IsEmpty(shArray1) Then
shArray1 = shArray2
Exit Sub
End If
`check each sheet name still exists as is
For lngCnt = 1 To UBound(shArray1)
vErr = Application.Match(shArray1(lngCnt, 1), strSht, 0)
If IsError(vErr) Then
strOut = strOut & shArray1(lngCnt, 1) & vbNewLine
vErr = Empty
End If
Next
shArray1 = Application.Transpose([INDEX(shtNames,)])
If Len(strOut) > 0 Then MsgBox strOut, vbCritical, "These sheets are gone or renamed"
End Sub

Tracing precedents in external spreadsheets using Excel VBA

I'm currently trying to trace the dependencies of a complex set of Excel spreadsheets. My ideal end goal would be a tree structure, starting with my first spreadsheet. However, I don't want to include all of the dependencies of the child spreadsheets, just the ones of the cells referenced by the original spreadsheet. For example:
In cell A1 of my first workbook:
somebook.xls!Sheet1!C2
I want to look at cell C2 in sheet 1 of somebook.xls for its (external) dependencies, and then recurse.
At the moment I'm using LinkInfo to get a list of external dependencies, searching using Find, and I'm struggling with vbscript's primitive regex capabilities to try and extract the address out of the cells I find. This is not a brilliant way of doing things.
Does anyone know if Excel will tell you which cells in an external spreadsheet are being referenced? If not, any other tools that might help?
Thanks.
This answer is based off Bill Manville's macro from many years back. The macro still works, but I broke it out into functions allowing for more flexibility and reusability. The main addition by me is the ability to find external dependencies only, and the extension to both precedents and dependents. I also added a call to a custom macro called unhideAll; this was necessary for me as dependencies were not being found in hidden worksheets.
'Module for examining depedencies to/from a sheet from/to other sheets
Option Explicit
Sub showExternalDependents()
Dim deps As Collection
Set deps = findExternalDependents(ActiveCell)
Call showDents(deps, True, "External Dependents: ")
End Sub
Sub showExternalPrecedents()
Dim precs As Collection
Set precs = findExternalPrecedents(ActiveCell)
Call showDents(precs, True, "External Precedents: ")
End Sub
'external determines whether or not to print out the absolute address including workbook & worksheet
Sub showDents(dents As Collection, external As Boolean, header As String)
Dim dent As Variant
Dim stMsg As String
stMsg = ""
For Each dent In dents
stMsg = stMsg & vbNewLine & dent.Address(external:=external)
Next dent
MsgBox header & stMsg
End Sub
Function findPrecedents(rng As Range) As Collection
Set findPrecedents = findDents(rng, True)
End Function
Function findDependents(rng As Range) As Collection
Set findDependents = findDents(rng, False)
End Function
Function findExternalPrecedents(rng As Range) As Collection
Set findExternalPrecedents = findExternalDents(rng, True)
End Function
Function findExternalDependents(rng As Range) As Collection
Set findExternalDependents = findExternalDents(rng, False)
End Function
'Gives back only the dependencies that are not on the same sheet as rng
Function findExternalDents(rng As Range, precDir As Boolean) As Collection
Dim dents As New Collection
Dim dent As Range
Dim d As Variant
Dim ws As Worksheet
Set ws = rng.Worksheet
For Each d In findDents(rng, precDir)
Set dent = d
With dent
If Not (.Worksheet.Name = ws.Name And .Worksheet.Parent.Name = ws.Parent.Name) Then _
dents.Add Item:=dent
End With
Next d
Set findExternalDents = dents
End Function
'this procedure finds the cells which are the direct precedents/dependents of the active cell
'If precDir is true, then we look for precedents, else we look for dependents
Function findDents(rng As Range, precDir As Boolean) As Collection
'Need to unhide sheets for external dependencies or the navigate arrow won't work
Call mUnhideAll
Dim rLast As Range, iLinkNum As Integer, iArrowNum As Integer
Dim dents As New Collection
Dim bNewArrow As Boolean
'Appliciation.ScreenUpdating = False
If precDir Then
ActiveCell.showPrecedents
Else
ActiveCell.ShowDependents
End If
Set rLast = rng
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
ActiveCell.NavigateArrow TowardPrecedent:=precDir, ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
If Err.Number > 0 Then Exit Do
On Error GoTo 0
If rLast.Address(external:=True) = ActiveCell.Address(external:=True) Then Exit Do
bNewArrow = False
dents.Add Item:=Selection
iLinkNum = iLinkNum + 1 ' try another link
Loop
If bNewArrow Then Exit Do
iLinkNum = 1
bNewArrow = True
iArrowNum = iArrowNum + 1 'try another arrow
Loop
rLast.Parent.ClearArrows
Application.Goto rLast
Set findDents = dents
End Function
Sub mUnhideAll()
'
' mUnhideAll Macro
'
' Unhide All
Dim ws As Worksheet
For Each ws In Worksheets
ws.Visible = True
Next
'Sheets("Sprint Schedule Worksheet").Visible = False
End Sub
Excel's built in support, as you're finding, is limited and can be extremely frustrating.
In my experience, I've found a couple of tools from http://www.aivosto.com/ to be useful; Visustin v6 is especially useful for code related auditting/processing.
Here's a simpler version of Colm Bhandal's findDents and findExternalDents. It assumes all worksheets were made visible and arrows were cleared before use.
Function findDents(rCell As Range, bPrec As Boolean) As Collection
'Return all direct precedents (bPrec=True) or dependents (bPrec=False) of rCell
Dim sAddr As String, nLink As Integer, nArrow As Integer
Const bAbs As Boolean = False, bExt As Boolean = True
Set findDents = New Collection
If bPrec Then
rCell.showPrecedents ' even if rCell has no formula
Else
rCell.showDependents
End If
On Error Resume Next ' ignore errors
sAddr = rCell.Address(bAbs, bAbs, xlA1, bExt)
nArrow = 1
Do
nLink = 1
Do
rCell.NavigateArrow bPrec, nArrow, nLink
If ActiveCell.Address(bAbs, bAbs, xlA1, bExt) = sAddr Then Exit Do
findDents.Add Selection ' possibly more than one cell
nLink = nLink + 1
Loop
If nLink = 1 Then Exit Do
nArrow = nArrow + 1
Loop
On Error GoTo 0
If bPrec Then
rCell.showPrecedents Remove:=True
Else
rCell.showDependents Remove:=True
End If
End Function
Function findExternalDents(rCell As Range, bPrec As Boolean) As Collection
'Return ...Dents that are NOT in the same workbook and worksheet as rCell
Dim rDent As Range, wsName As String, wbName As String
With rCell.Worksheet: wsName = .Name: wbName = .Parent.Name: End With
Set findExternalDents = New Collection
For Each rDent In findDents(rCell, bPrec)
If rDent.Worksheet.Name <> wsName Or rDent.Worksheet.Parent.Name <> wbName Then findExternalDents.Add Item:=rDent
Next rDent
End Function
You might want to modify this to use a SortedList instead of a Collection. In that case, change
findDents.Add Selection
to
findDents.Add Selection.Address(bAbs, bAbs, xlA1, bExt), Null

Excel listing named range in a worksheet and get the value

How to obtain a list of named range exist in a specific worksheet that start with particular string (for example all named range that start with total) and grab the value? I am trying to do Sub Total and Grand Total of accommodation cost based on the date. I will assign an unique name for each Sub Total based on the Date group. Then, I have a button that need to be clicked when it finishes to calculate the Grand Total based on the Named Range that I've assigned uniquely to each Sub Total.
Below is the code I wrote to do the Grand Total:
Sub btnTotal()
Dim Total, LastRowNo As Long
LastRowNo = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
Total = 0
For Each N In ActiveWorkbook.Names
Total = Total + IntFlight.Range(N.Name).Value
Next N
IntFlight.Range("$P" & LastRowNo).Select
Selection.NumberFormat = "$* #,##0.00;$* (#,##0.00);$* ""-""??;#"
With Selection
.Font.Bold = True
End With
ActiveCell.FormulaR1C1 = Total
End Sub
Note: the IntFlight from "Total = Total + IntFlight.Range(N.Name).Value" is the name of my worksheet.
The only problem with above code, it will looking all named range exist in the workbook. I just need to find named range exist in one particular worksheet, which start with given string and the row number (total26: means Sub Total from row 26) and then grab the value to be sum-ed as Grand Total.
Any ideas how to do this? Been spending 2 days to find the answer.
Thanks heaps in advance.
EDIT 1 (Solution Provided by Charles Williams with help from belisarius):
This is what I have done with the code from Charles Williams:
Option Explicit
Option Compare Text
Sub btnIntFlightsGrandTotal()
Dim Total, LastRowNo As Long
LastRowNo = FindLastRowNo("International Flights")
Dim oNM As Name
Dim oSht As Worksheet
Dim strStartString As String
strStartString = "IntFlightsTotal"
Set oSht = Worksheets("International Flights")
For Each oNM In ActiveWorkbook.Names
If oNM.Name Like strStartString & "*" Then
If IsNameRefertoSheet(oSht, oNM) Then
Total = Total + Worksheets("International Flights").Range(oNM.Name).Value
End If
End If
Next oNM
IntFlights.Range("$P" & LastRowNo).Select
Selection.NumberFormat = "$* #,##0.00;$* (#,##0.00);$* ""-""??;#"
With Selection
.Font.Bold = True
End With
ActiveCell.FormulaR1C1 = Total
End Sub
Function FindLastRowNo(SheetName As String) As Long
Dim oSheet As Worksheet
Set oSheet = Worksheets(SheetName)
FindLastRowNo = oSheet.UsedRange.Row + oSheet.UsedRange.Rows.Count
End Function
Thank you all for your help. Now, I need to come up with my own version for this script.
Here is some code that checks if a Defined Name starts with a string and refers to a range within the used range of a given worksheet and workbook.
Option Explicit
Option Compare Text
Sub FindNames()
Dim oNM As Name
Dim oSht As Worksheet
Dim strStartString As String
strStartString = "Total"
Set oSht = Worksheets("TestSheet")
For Each oNM In ActiveWorkbook.Names
If oNM.Name Like strStartString & "*" Then
If IsNameRefertoSheet(oSht, oNM) Then
MsgBox oNM.Name
End If
End If
Next oNM
End Sub
Function IsNameRefertoSheet(oSht As Worksheet, oNM As Name) As Boolean
Dim oSheetRange As Range
IsNameRefertoSheet = False
On Error GoTo GoExit
If Not oSht Is Nothing Then
If Range(oNM.Name).Parent.Name = oSht.Name And _
Range(oNM.Name).Parent.Parent.Name = oSht.Parent.Name Then
Set oSheetRange = oSht.Range("A1").Resize(oSht.UsedRange.Row + oSht.UsedRange.Rows.Count - 1, oSht.UsedRange.Column + oSht.UsedRange.Columns.Count - 1)
If Not Intersect(Range(oNM.Name), oSheetRange) Is Nothing Then IsNameRefertoSheet = True
Set oSheetRange = Nothing
End If
End If
Exit Function
GoExit:
End Function
The following function will output all the names and their totals in your Workbook.
I think it is the basic block you need to get your code running.
Sub btnTotal()
For Each N In ActiveWorkbook.Names
MsgBox N.Name + " " + CStr(Application.WorksheetFunction.Sum(Range(N)))
Next N
End Sub
Edit
Answering your comment:
Define your names in this way:
Then (and only then) the following code works:
Sub btnTotal()
For Each N In ActiveSheet.Names
If (InStr(N.Name, "!Total") <> 0) Then
MsgBox N.Name + " " + CStr(Application.WorksheetFunction.Sum(Range(N)))
End If
Next N
End Sub
If you do not define the scope of the names correctly you need a lot of extra work in your code.
Edit
As you forgot to mention that you are still working with Excel 2003, here you will find an addin to manage name scoping in that version. See screen cap below
HTH

Resources