How to populate list of names of worksheets

[minsk2000]

Hi Everyone,

I have to do some calculations with workbooks that have different numbers of worksheets (tabs) with different name.
I would like to create a standard worksheet and add it to each of the workbooks where in the column A I would be able to populate the list of tabs with their names.

Is there any forumula that could do that?

Thanks

 

[larrydunn]

Here goes. I'd forgotten I highlighted the names of sheets that weren't visible.

Sub GetSheets()
'Read sheet names into blank worksheet
Dim iMaxCount As Integer
Dim I As Integer
Dim sNewSheet As String

iMaxCount = Sheets.Count
If iMaxCount < 2 Then Exit Sub
Sheets.Add
sNewSheet = ActiveSheet.Name
iMaxCount = Sheets.Count
Sheets(sNewSheet).Move After:=Sheets(iMaxCount) 'Move to end
ActiveSheet.Range("A1").Select
For I = 1 To iMaxCount
ActiveCell.NumberFormat = "@"
ActiveCell.Value = Sheets(I).Name

If Sheets(I).Visible Then GoTo SheetWasVisibleSoOK

With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With

SheetWasVisibleSoOK:
ActiveCell.Offset(1, 0).Range("A1").Select 'Down
Next I
End Sub

 

[larrydunn]

Just for fun, here's the companion code to set the tab order to that of the names in the column.

Sub SetSheets()
'Sort sheets into sequence listed
Dim iMaxCount As Integer
Dim sWheel As String
Dim sSheetToPlace As String
Dim iMaxRow As Integer
Dim sOriginalCell As String
Dim sActualOriginalCell As String
Dim sActualSheets() As String
Dim sListedNames() As String
Dim iActualCount As Integer
Dim iListCount As Integer
Dim I As Integer
Dim J As Integer
Dim iWheelNo As Integer

If Selection.Columns.Count > 1 Then Exit Sub
iMaxCount = Sheets.Count
If iMaxCount < 2 Then Exit Sub
ReDim sActualSheets(iMaxCount)
sWheel = ActiveSheet.Name
iWheelNo = 0 'Assume that wheel sheet isn't listed

sOriginalCell = ActiveCell.Address
sActualOriginalCell = sOriginalCell
'Move to Excel's last recorded entry
ActiveCell.SpecialCells(xlLastCell).Select
iMaxRow = ActiveCell.Row
If ActiveCell.Column < 2 Then sOriginalCell = "A1"
ActiveSheet.Range(sOriginalCell).Select

FindTopOfColumn:
If ActiveCell.Row = 1 Then GoTo GetCountOfItems
ActiveCell.Offset(-1, 0).Range("A1").Select ' Move up
sOriginalCell = ActiveCell.Address
GoTo FindTopOfColumn

GetCountOfItems:
iListCount = iMaxRow - ActiveCell.Row + 1
If iListCount < 2 Then Exit Sub

ReDim sListedNames(iListCount)
iListCount = 0
ReadListOfNames:
If ActiveCell.Value = "" Then GoTo PrepareForNextName
iListCount = iListCount + 1
sListedNames(iListCount) = ActiveCell.Value
If UCase(ActiveCell.Value) = UCase(sWheel) Then iWheelNo = iListCount 'Remember position of wheel sheet
PrepareForNextName:
ActiveCell.Offset(1, 0).Range("A1").Select ' Move down
If ActiveCell.Row <= iMaxRow Then GoTo ReadListOfNames

ReadSheetNamesIntoArray:
For I = 1 To iMaxCount
If Sheets(I).Visible = True Then Sheets(I).Select
iActualCount = iActualCount + 1
sActualSheets(iActualCount) = ActiveSheet.Name
Next I

For J = 1 To iListCount
sSheetToPlace = sListedNames(J)
If sSheetToPlace = sWheel Then GoTo NoAdd

FindSheetInList:
I = 0
KeepFinding:
I = I + 1
If I > iActualCount Then GoTo NotPlaced
If UCase(sSheetToPlace) = UCase(sActualSheets(I)) Then GoTo PlaceItThen
GoTo KeepFinding

PlaceItThen:
Sheets(sSheetToPlace).Move Before:=Sheets(sWheel)
GoTo NoAdd

NotPlaced:
'Compensate for this not being a valid sheet
If J < iWheelNo Then iWheelNo = iWheelNo - 1
NoAdd:
Next J

If iWheelNo < 1 Then GoTo EOS
Sheets(sWheel).Move Before:=Sheets(iWheelNo)

EOS:
Sheets(sWheel).Select
ActiveSheet.Range(sActualOriginalCell).Select
End Sub