J
jnf40
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.
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.