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.

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

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