View Single Post
  #5   Report Post  
Posted to microsoft.public.excel.programming
Bill Renaud Bill Renaud is offline
external usenet poster
 
Posts: 417
Default Copy & rename a sheet appending 01,02,03 ..etc

JC:

I don't write the shortest code of anybody around, but I usually always get
what I want and it works!!! The following code copies the currently active
sheet, assuming that it does not already have a sequence number appended on
the end, and names it the same with an incremented number appended on the
end. If the active worksheet already appears to have a sequence number on
the end of the name, the routine displays an error message and does not
copy. As far as the number of digits in the sequence number are concerned,
it uses the same number of digits as the previous sheet. So, if the active
sheet is named "WeekA" and is the only copy so far, then the new copy will
be "WeekA1". If the largest copy so far is "WeekA001", then the next copy
of "WeekA" will be "WeekA002" and so on. The new copy is placed to the
right of the copy with the largest sequence number so far. The originally
active sheet will be re-activated at the end of the routine.

Let us know how you like it!

Option Explicit

'----------------------------------------------------------------------
Public Sub CopyAndRenameWorksheet()
'Code by Bill Renaud.
Dim wsOriginal As Worksheet
Dim wsLast As Worksheet
Dim wsNew As Worksheet

Dim strBaseName As String
Dim strSequence As String

Application.ScreenUpdating = False

Set wsOriginal = ActiveSheet

SplitString wsOriginal.Name, strBaseName, strSequence
If strSequence < "" Then GoTo ErrCopyAndRenameWorksheet

Set wsLast = LastSequencedWorksheet(wsOriginal)

With wsOriginal
.Copy After:=wsLast
Set wsNew = Worksheets(wsLast.Index + 1) 'Set reference to new
worksheet.
End With

With wsNew
If wsLast Is wsOriginal _
Then
'This is the first sequenced worksheet to be added.
.Name = wsOriginal.Name & "1"
Else
'Copy the naming format from the previously sequenced worksheet.
SplitString wsLast.Name, strBaseName, strSequence
.Name = wsOriginal.Name & _
Format$(CLng(strSequence) + 1, _
String(Len(strSequence), "0"))
End If
End With

'Re-activate original worksheet.
wsOriginal.Activate
Exit Sub

ErrCopyAndRenameWorksheet:
MsgBox "Active worksheet is a copy" & vbNewLine & _
"of the original worksheet.", _
vbCritical + vbOKOnly, _
"Error Copying and Renaming Worksheet"
End Sub

'----------------------------------------------------------------------
'LastSequencedWorksheet locates the worksheet in the workbook that has
'the highest sequence number, based on an original worksheet. If there
'are no sequenced worksheets, then a reference to the original worksheet
'is returned.

Private Function LastSequencedWorksheet(wsOriginal As Worksheet) _
As Worksheet

Dim wb As Workbook
Dim ws As Worksheet
Dim wsLast As Worksheet
Dim lngLast As Long

Dim strBaseName As String
Dim strSequence As String

Set wb = wsOriginal.Parent
Set wsLast = Nothing
lngLast = 0

'Locate the highest sequence numbered worksheet.
For Each ws In wb.Worksheets
SplitString ws.Name, strBaseName, strSequence
If strBaseName = wsOriginal.Name And _
strSequence < "" _
Then
If CLng(strSequence) lngLast _
Then
'Capture and keep this highest sequenced worksheet.
Set wsLast = ws
lngLast = CLng(strSequence)
End If
End If
Next ws

If wsLast Is Nothing _
Then
Set LastSequencedWorksheet = wsOriginal
Else
Set LastSequencedWorksheet = wsLast
End If
End Function

'----------------------------------------------------------------------
'SplitString splits an expression into 2 parts. Sequence is the
'contiguous string of digits from the right end of the string.
'BaseName is the remainder of the string to the left of Sequence.
'Blank strings are returned for each part that does not exist.
'
' Expression BaseName Sequence
' ---------- -------- --------
' "" "" ""
' Sheet Sheet ""
' Sheet1A Sheet1A ""
' Sheet1 Sheet 1
' Sheet01 Sheet 01
' 123 "" 123

Public Sub SplitString(Expression As String, _
BaseName As String, _
Sequence As String)

Dim lngLastNonDigit As Long

If Expression = "" Then GoTo ErrNoString

lngLastNonDigit = Len(Expression)

While (Mid$(Expression, lngLastNonDigit, 1) Like "#")
'Character is a digit, so step left one character.
lngLastNonDigit = lngLastNonDigit - 1
If lngLastNonDigit = 0 Then GoTo Continue
Wend

Continue:
BaseName = Left$(Expression, lngLastNonDigit)
Sequence = Right$(Expression, Len(Expression) - lngLastNonDigit)

GoTo ExitSub

ErrNoString:
BaseName = ""
Sequence = ""

GoTo ExitSub

ExitSub:
End Sub

--
Regards,
Bill Renaud