Ps. Tell the users to use () around the numbers and < around text! Your life
would be easier <vbg.

Dave Peterson wrote:

This wasn't vigorously tested:

Option Explicit
Sub testme()

Dim MyNames() As String
Dim myCount() As Long
Dim wksCount As Long
Dim wks As Worksheet
Dim wCtr As Long
Dim wkbk As Workbook
Dim LastSpaceOpenParen As Long
Dim myAdjName As String
Dim res As Variant
Dim TestRng As Range
Dim CurNum As String
Dim ShtOfName As String
Dim StuffInParens As String
Dim NumberInParens As Boolean

Set wkbk = ActiveWorkbook
ShtOfName = "sht_of_"

wksCount = wkbk.Worksheets.Count

wCtr = 0
ReDim MyNames(1 To wksCount)
ReDim myCount(1 To wksCount)
For Each wks In wkbk.Worksheets
NumberInParens = False
If wks.Name Like "* (*)" Then
'just increment the count,
'the base name should be already in the list
LastSpaceOpenParen = InStrRev(wks.Name, " (")
StuffInParens = Mid(wks.Name, LastSpaceOpenParen + 2)
StuffInParens = Left(StuffInParens, Len(StuffInParens) - 1)

If IsNumeric(StuffInParens) Then
NumberInParens = True
myAdjName = Left(wks.Name, LastSpaceOpenParen - 1)
res = Application.Match(myAdjName, MyNames, 0)
If IsError(res) Then
wCtr = wCtr + 1
MyNames(wCtr) = myAdjName
Else
myCount(res) = myCount(res) + 1
End If
End If
End If
If NumberInParens = False Then
wCtr = wCtr + 1
MyNames(wCtr) = wks.Name
myCount(wCtr) = 1
End If
Next wks

If wCtr = 0 Then
MsgBox "somthing went horribly wrong"
Exit Sub
End If

ReDim Preserve MyNames(1 To wCtr)
ReDim Preserve myCount(1 To wCtr)

'loop again
For Each wks In wkbk.Worksheets
NumberInParens = False
Set TestRng = Nothing
On Error Resume Next
Set TestRng = wks.Range(ShtOfName)
On Error GoTo 0
If TestRng Is Nothing Then
'do nothing to this sheet
Else
If wks.Name Like "* (*)" Then
LastSpaceOpenParen = InStrRev(wks.Name, " (")

StuffInParens = Mid(wks.Name, LastSpaceOpenParen + 2)
StuffInParens = Left(StuffInParens, Len(StuffInParens) - 1)

If IsNumeric(StuffInParens) Then
NumberInParens = True
myAdjName = Left(wks.Name, LastSpaceOpenParen - 1)
'get rid of ()'s
CurNum = Mid(wks.Name, LastSpaceOpenParen + 2)
CurNum = Left(CurNum, Len(CurNum) - 1)
End If
End If

If NumberInParens = False Then
myAdjName = wks.Name
CurNum = 1
End If

res = Application.Match(myAdjName, MyNames, 0)
If IsError(res) Then
MsgBox "this shouldn't happen!"
Exit Sub
Else
wks.Range(ShtOfName).Value _
= "Sheet " & CurNum & " of " & myCount(res)
End If
End If

Next wks
End Sub

jnf40 wrote:

In an earlier post from 09/08/2006 you gave me the following answer to the
following question, and it worked great.

I have a workbook that adds worksheets, names them and sorts them...My sheet
names are fine as they are with the cell entry...On the worksheet itself I
have a cell with 'Sheet' typed in it then a blank cell named Sht_of_ , the
next cell has 'of' typed in it then a blank cell named Sht_of_1...Looks
something like this,
Sheet_____ of _____...I want the numbering to go into these cells named
Sht_of_ and Sht_of_1...So if I have 2 worksheets named DBL ARROW and
DBL ARROW (2)...then
worksheet DBL ARROW would have Sheet 1 of 2 and
worksheet DBL ARROW (2) would have Sheet 2 of 2
if another worksheet was created later and it's name was
DBL ARROW (3) then
sheet DBL ARROW cells would change to Sheet 1 of 3
sheet DBL ARROW (2) cells would change to Sheet 2 of 3...and
sheet DBL ARROW (3) cells would be Sheet 3 of 3.

This may get you close:

Option Explicit
Sub testme()

Dim MyNames() As String
Dim myCount() As Long
Dim wksCount As Long
Dim wks As Worksheet
Dim wCtr As Long
Dim wkbk As Workbook
Dim LastSpaceOpenParen As Long
Dim myAdjName As String
Dim res As Variant
Dim TestRng As Range
Dim CurNum As String
Dim ShtOfName As String

Set wkbk = ActiveWorkbook
ShtOfName = "sht_of_"

wksCount = wkbk.Worksheets.Count

wCtr = 0
ReDim MyNames(1 To wksCount)
ReDim myCount(1 To wksCount)
For Each wks In wkbk.Worksheets
If wks.Name Like "* (*)" Then
'just increment the count,
'the base name should be already in the list
LastSpaceOpenParen = InStrRev(wks.Name, " (")
myAdjName = Left(wks.Name, LastSpaceOpenParen - 1)
res = Application.Match(myAdjName, MyNames, 0)
If IsError(res) Then
wCtr = wCtr + 1
MyNames(wCtr) = myAdjName
Else
myCount(res) = myCount(res) + 1
End If
Else
wCtr = wCtr + 1
MyNames(wCtr) = wks.Name
myCount(wCtr) = 1
End If
Next wks

If wCtr = 0 Then
MsgBox "somthing went horribly wrong"
Exit Sub
End If

ReDim Preserve MyNames(1 To wCtr)
ReDim Preserve myCount(1 To wCtr)

'loop again
For Each wks In wkbk.Worksheets
Set TestRng = Nothing
On Error Resume Next
Set TestRng = wks.Range(ShtOfName)
On Error GoTo 0
If TestRng Is Nothing Then
'do nothing to this sheet
Else
If wks.Name Like "* (*)" Then
LastSpaceOpenParen = InStrRev(wks.Name, " (")
myAdjName = Left(wks.Name, LastSpaceOpenParen - 1)
'get rid of ()'s
CurNum = Mid(wks.Name, LastSpaceOpenParen + 2)
CurNum = Left(CurNum, Len(CurNum) - 1)
Else
myAdjName = wks.Name
CurNum = 1
End If

res = Application.Match(myAdjName, MyNames, 0)
If IsError(res) Then
MsgBox "this shouldn't happen!"
Exit Sub
Else
wks.Range(ShtOfName).Value _
= "Sheet " & CurNum & " of " & myCount(res)
End If
End If

Next wks
End Sub

Now the users have thrown me a curve and I can't figure out how to make it
work.
They have entered the following for a sheet name:

235 REPR TY (T4 (S) RAIL)

when it runs the the code it gives me

Sheet S) RAIL of 0

The new second sheet with the same name is

235 REPR TY (T4 (S) RAIL) (2) this is correct

but the Sheet of is

Sheet 2 of 0

any help is greatly appreciated.

--

Dave Peterson

--

Dave Peterson