Collections

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

Workbook/Worksheet collection

Worksheets Collection Example showing Name, index, CodeName, Parent

 ABCDEF
†1collection †Index†Name [on sheet]†CodeName †Parent†Worksheets(n)
†2†worksheets(1) †1††Sheet144†Sheet178 †2004-11.xls†Sheet144
†3†worksheets(2) †2††test†Sheet181†2004-11.xls †test
†4†worksheets(3) †3††spare†Sheet182†2004-11.xls †spare
†5†worksheets(4) †4††Sheet145†Sheet179 †2004-11.xls†Sheet145
†6†worksheets(5) †5††Sheet143†Sheet180 †2004-11.xls†Sheet143
Private Sub Worksheet_BeforeDoubleClick(ByVal Target _
     As Range, Cancel As Boolean)
Dim wkSheet As Worksheet
Dim x As Long, cSht As Long
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Cancel = True   'Get of Edit mode established with double-click
    Range("A1:F1") = Array("collection", "Index", _
         "Name  [on sheet]", "CodeName", "Parent")
    For Each wkSheet In Application.Worksheets
       cSht = cSht + 1
       Cells(cSht + 1, 1) = "'worksheets(" & cSht & ")"
       Cells(cSht + 1, 2) = wkSheet.Index
       Cells(cSht + 1, 3) = "'" & wkSheet.Name
       Cells(cSht + 1, 4) = "'" & wkSheet.CodeName
       Cells(cSht + 1, 5) = "'" & wkSheet.Parent.Name
       Cells(cSht + 1, 6) = "'" & Worksheets(cSht).Name
   Next wkSheet
   Rows("1:1").Font.Bold = True
   Rows("1:1").Font.Underline = xlUnderlineStyleSingle
   With Range("C1").Characters(Start:=5, Length:=12).Font
        .FontStyle = "Regular"
        .Underline = xlUnderlineStyleNone
   End With
   Cells.EntireColumn.AutoFit
   Application.Calculation = xlCalculationAutomatic
   Application.ScreenUpdating = True
End Sub
The Above code includes these aspects

Using the workbooks and Worksheets collections

Dim wkBook As Workbook
Dim wkSheet As Worksheet
Dim x As Long, cSht As Long
For Each wkBook In Workbooks
   x = x + 1: cSht = 0
   Cells(1, x) = wkBook.Name
   For Each wkSheet In wkBook.Worksheets
      cSht = cSht + 1
      Cells(cSht + 1, x) = "'" & wkSheet.Name
   Next wkSheet
Next wkBook
Or using wkBook.Worksheets.Count
Dim wkBook As Workbook
Dim wkSheet As Worksheet
Dim x As Long, cSht As Long
For Each wkBook In Workbooks
   x = x + 1
   Cells(1, x) = wkBook.Name
   For cSht = 1 To wkBook.Worksheets.Count
      Cells(cSht + 1, x) = "'" & wkBook.Worksheets(cSht).Name
   Next cSht
Next wkBook
List names of sheets down from active cell (Example in buildtoc.htm)
Sub SheetNamesDownRows()
  Dim iSheet As Long
  For iSheet = 1 To ActiveWorkbook.WorkSheets.Count
    ActiveCell.offset(iSheet - 1,0) = "'" & WorkSheets(iSheet).Name
  Next iSheet
End Sub
To use Grouped worksheets (selected worksheets) instead of all worksheets use:  (also see example in insrtrow.htm)
   for each wkSheet in Application.ActiveWorkbook.Windows(1).SelectedSheets

Repeat top 3 lines on all sheets in workbook for each worksheet item in the collection

You cannot select all sheets and use File, Page Setup, Sheets, Rows to Repeat at top: $1:$3
so you would need a macro.
Option Explicit
Sub Top3LinesAllSheets()
   Dim wkSheet As Worksheet
   For Each wkSheet In Application.Worksheets
        With wkSheet.PageSetup
          .PrintTitleRows = "$1:$3"
       End With
       Sheets(wkSheet.Name).Rows("1:3").Font.Bold = True
   Next wkSheet
End Sub

Using the Worksheets.count

Dim wc As Long
For wc = 1 To ThisWorkbook.Worksheets.Count
  ThisWorkbook.Worksheets(wc).PrintOut
next wc

Obtaining Cell Counts for all Sheets in All Open Workbooks

 ABCDEFG
1workbookSheet posrowscolsCells Value in A1
2martin.xls.xls$$ TOC 1S259 225 
3martin.xls.xls2001-09-25 5S359 3151
4martin.xls.xlsSheet10 11S218 168B1
5martin.xls.xlsSheet11 12S1784 712Bookmarks
6martin.xls.xlsSheet2 19S6387 4466A1
7martin.xls.xlsv.grades 27S216 126Lower Limit
8personal.xlsSheet1 1S10 0 
Sub AllsheetsInOpenBooks()   
'Example in http://www.mvps.org/dmcritchie/excel/collections.htm  
Dim wkBook As Workbook, wkSheet As Worksheet   ' 2001-11-24
Dim iRow As Long, iSheet As Long:   iRow = 1
'Create a new sheet in the current workbook
'  added sheet automatically becomes the active sheet.
   Worksheets.Add After:=Sheets(Sheets.Count)
   Set wkSheet = ActiveSheet
   Columns("A:B").NumberFormat = "@"
   Columns("C").NumberFormat = "#,###""S"""
   Range("a1:g1") = Array("workbook", "Sheet", _
      "pos", "rows", "cols", "Cells", "Value in A1")
   Rows("1:1").Font.Bold = True
For Each wkBook In Workbooks
   iSheet = 0
   For Each wkSheet In wkBook.Worksheets
      iRow = iRow + 1: iSheet = iSheet + 1
      Cells(iRow, 1) = wkBook.Name
      Cells(iRow, 2) = wkSheet.Name
      Cells(iRow, 3) = iSheet 'placement
      'can't use SpecialCells(xlLastCell) if protected
      Cells(iRow, 4).Value = wkSheet.UsedRange.Rows.Count
      Cells(iRow, 5).Value = wkSheet.UsedRange.Columns.Count
      Cells(iRow, 6) = Cells(iRow, 4) * Cells(iRow, 5)
      Cells(iRow, 7) = wkSheet.Cells(1, 1).Text
      On Error GoTo 0
   Next wkSheet
Next wkBook
    Cells.EntireColumn.AutoFit
    If Columns("G").ColumnWidth > 45 Then _
       Columns("G").ColumnWidth = 43
    '-- Sort results
    Cells.Sort Key1:=Range("A2"), Order1:=xlAscending, _
        Key2:=Range("B2"), Order2:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom
    Range("A1").Select
End Sub

Open the Workbooks seen in column A

sPath = "C:\My Documents\"
On Error Resume Next
For each cell in Range("A1",Range("a1").End(xlDown))
    workbooks.open Filename:=sPath & cell.Value & ".xls"
Next
On Error goto 0
For Each cell In Range("A1", Range("a1").End(xlDown))
    Workbooks.Open (cell & ".xls")
                If Err.Number = 1004 Then
       MsgBox "Does not exist"
    End If
Next

Run a macro against all Workbooks in a directory (#foundfiles)

A solution provided by Tom Ogilvy, 2001-08-05, in programming. which he indicates is an adaptation of code from help on FileSearch object
Sub ProcessBooks()
Dim wkbk As Workbook
Dim i As Long
With Application.FileSearch
    .NewSearch
    .LookIn = "C:\My Documents"
    .SearchSubFolders = False
    .FileName = "*.xls"
    .FileType = msoFileTypeExcelWorkbooks
    If .Execute() > 0 Then
        For i = 1 To .FoundFiles.Count
            Set wkbk = _
              Workbooks.Open(FileName:=.FoundFiles(i))
            ' run macro to process file
            wkbk.Close SaveChanges:=True
        Next i
    Else
        MsgBox "There were no files found."
    End If
End With
End Sub

More directory things

Close all Workbooks except active (#workbooks)

Sub CloseAllButActive()
  'based on Tom Ogilvy's postings
  Dim wkbk As Workbook
  For Each wkbk In Application.Workbooks
    If wkbk.Name <> ActiveWorkbook.Name Then
      If Windows(wkbk.Name).Visible = True Then
        'MsgBox wkbk.Name & " " & Windows(wkbk.Name).Visible
        wkbk.Close SaveChanges:=False  'or make it true
      End If
    End If
  Next
End Sub
... see BarHopper

Defined Names Collection (#names)

Sub a()
    Dim Nm As Name
    For Each Nm In Names
        Nm.Visible = True
    Next
End Sub

Sub ShowNames()
   Dim N As Long
   For N = 1 To ActiveWorkbook.Names.Count
      On Error Resume Next
      Cells(N, 1) = "'" & ActiveWorkbook.Names(N).Name
      Cells(N, 2) = "'" & ActiveWorkbook.Names(N).RefersToRange.Address
      Cells(N, 3) = "'" & ActiveWorkbook.Names(N).ShortcutKey
      Cells(N, 4) = "'" & ActiveWorkbook.Names(N).Visible
   Next
End Sub
To find the name for a specific cell You can use the Name property twice to get the Name of the Defined Name. (Jake Maxx)
Sub ShowNames_activecell()
    On Error Resume Next
    MsgBox ActiveCell.Name.Name
    Select Case Err.Number
        Case 0
        Case 1004
            MsgBox "No name for cell " & ActiveCell.Address(4)
        Case Else
            MsgBox Err.Number & " -- " & Err.Description
    End Select
End Sub
To change the range to which the name refers, you don’t need to delete the name first, you can just use the Add method of the Names collection (Dick Kusleika).  For instance, if I name Sheet1!A1 'Hello', selected A1 and run this line
    Sheet1.Names.Add Selection.Name.Name, Sheet1.Range("b2")

List all names in workbook (#listnames)

Sub List_Named_Ranges()
Dim nms As Names
Dim n As Long 'count of range names
On Error Resume Next
Set nms = ActiveWorkbook.Names
      For n = 1 To nms.Count
        Cells(n, 2).Value = nms(n).Name
        Cells(n, 3).Value = nms(n).RefersToRange.Address
        Cells(n, 4) = nms(n).Visible
      Next
End Sub
additional Name objects
Application, Category, CategoryLocal, Creator, Delete, Index, MacroType, Name, NameLocal, Parent, RefersTo, RefersToLocal, RefersToR1C1, ReferstoR1C1Local, RefersToRange, ShortcutKey, Value, Visible

Names References

Delete Names with LIKE names (#like)

This example (LIKE operator) deletes every defined name that contains “temp”.  The Option Compare Text statement must be included at the top of any module that contains this example.  More on RegExpr (regular expressions).  Another example of LIKE appears for drawing objects collection.
For Each nm In ActiveWorkbook.Names
    If nm.Name Like "*temp*" Then
        nm.Delete
    End If
Next nm
The following contains example code for going through the worksheets in the workbook and/or coloring each object type hyperlink.  Just an example.  Note we have to use parent.address because .address would the link.  The buildtoc.htm page contains most of material on hyperlinks.  Example by Dave Peterson (2001-12-13)
Sub ColorLinks()
    Dim myLnk As Hyperlink
   'Dim wks As Worksheet
   ' For Each wks In ActiveWorkbook.Worksheets
       'For Each myLnk In wks.Hyperlinks
        For Each myLnk In ActiveSheet.Hyperlinks
           'MsgBox myLnk.Parent.Address & vbLf _
                  & myLnk.Parent.Parent.Name
            Range(myLnk.Parent.Address).Interior.ColorIndex = 34
        Next myLnk
   ' Next wks
End Sub
A posting by Bill Manville to fix hyperlinks (fixhyperlinks, change hyperlinks) can be found in excel.links 2002-10-18

I would make a change on the second inputbox to save some typing.
stTo = InputBox("Replace with?","replace",stFrom)

The possible changes should be obvious.
  H.address would be the URL or other hyperlink address
  H.subaddress would be the cell or a module, if it applied
  H.texttodisplay is what you see

Option Explicit
Sub FixHyperlinks()
    'modified from Bill Manville, 2002-10-12 excel.links
    ' http://groups.google.com/groups?threadm=VA.00000eb9.04d15f2c%40msn.com
    Dim H As Hyperlink
    Dim stFrom As String, stTo As String
    stFrom = "sheet29"
    stFrom = InputBox("Replace what?")
    If stFrom = "" Then Exit Sub
    stTo = InputBox("Replace with?", "replace", stFrom)
    If stTo = "" Or stTo = stFrom Then  
       msgbox "Coward -- cancelled out"
       Exit Sub
    End if
 'Dim wks As Worksheet
 'For Each wks In ActiveWorkbook.Worksheets
   'For Each H In wks.Hyperlinks
    For Each H In ActiveSheet.Hyperlinks
       H.TextToDisplay = Replace(H.TextToDisplay, stFrom, stTo)
       H.Address = Replace(H.Address, stFrom, stTo)
       H.SubAddress = Replace(H.SubAddress, stFrom, stTo)
   Next H
 'Next wks
End Sub

DrawingObjects collection (#draw)

This example (LIKE operator) adds an arrowhead to every shape on Sheet1 that has the word “Line” in its name.  More on RegExpr (regular expressions).
For Each d In Worksheets("Sheet1").DrawingObjects
    If d.Name Like "*Line*" Then
        d.ArrowHeadLength = xlLong
        d.ArrowHeadStyle = xlOpen
        d.ArrowHeadWidth = xlNarrow
    End If
Next

Right-Click Menus (#rclick)

The following is from Jim Rech, 2001-06-14, misc, to list right-click menus.
"Jim Rech" <jarech@kpmg.com> wrote in message news:#FbWaQP9AHA.408@tkmsftngp05
> Given that most popup commandbars appear via a mouse right-click you could
> list all of them (popups) with this macro:
>
Sub ListPopups()
Dim CB As CommandBar
Dim Counter As Long
For Each CB In CommandBars
    If CB.Type = msoBarTypePopup Then
        Counter = Counter + 1
        Cells(Counter, 1).Value = CB.Name
    End If
Next
End Sub

> And then select any one that looked interesting and run this
> macro to see what it looks like: (slight modifications)
>
Sub RunPopup()
    If  IsEmpty(ActiveCell) then exit sub
    On Error Resume Next
    Err.Number = 0
    CommandBars(ActiveCell.Value).ShowPopup
    If Err.Number <> 0 Then
      MsgBox Err.Number & " " & Err.Description _
       & Chr(10) & "Helpcontext: " & Err.HelpContext _
       & Chr(10) & "Helpfile: " & Err.HelpFile _
       & Chr(10) & "Source: " & Err.Source
    End If
End Sub
>
> Of course you'd have to figure out in what context a given
> commandbar pplies to see it in normal use.
>
'
'The following Event macro simplifies usage of the above.  David
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  'Use  Alt  or  Esc  to clear popup
  RunPopup
End Sub
More on Right Click (Context) Menus
More on extracting information from Menus see bar hopper

There is No Collection name for...

ComboBox, see Chip Pearson’s code and explanation in Google of OLEObject container

what icon button is this? (#icon)

... place holder, perhaps would be better in toolsbars if have something

Collections, items, properties (#items)

Thought this little posting by Orlando Magalh„es Filho might help explain property.
In VBA Sheets is a collection and Sheet is a property.  From a collection you can extract items from it, in Sheets you can extract a Sheet with the item property.

The Item property returns a single object from a collection.  The following example sets the firstSheet variable to a Sheet object that represents Sheet one (as seen by the leftmost sheet tab).
  Set firstSheet = Sheets.Item(1)

The Item property is the default property for most collections, so you can write the same statement more concisely by omitting the Item keyword.
  Set firstSheet = Sheets(1)

Note for most applications you would be using Worksheet and Worksheets instead of Sheets and Sheet.  The Sheets collection is useful when you want to return sheets of any type.  A Worksheet is a spreadsheet.  The Sheets collection includes Worksheets, and Charts.  Prior to Excel 97 macros were in Macro sheets.
This page was introduced on June 30, 2001. 

[My Excel Pages -- home]    [INDEX to my site and the off-site pages I reference] 
[Site Search -- Excel]     [Go Back]    [Return to TOP

Please send your comments concerning this web page to: David McRitchie send email comments


Copyright © 1997 - 2004,  F. David McRitchie,  All Rights Reserved