Re: Sheets.Add Function

Tech-Archive recommends: Fix windows errors by optimizing your registry

I know it is a lot of code, but you may find it useful:


Function Add***(ByVal str*** As String, _
ByVal bOverwrite As Boolean, _
ByVal lLocation As Long, _
Optional ByVal bClear As Boolean = True, _
Optional ByVal bActivate As Boolean = True, _
Optional bSetScreenUpdating As Boolean = True, _
Optional strCallingProc As String) As String

'str***, name of the new ***
'bOverWrite, clear existing *** and don't use new *** if TRUE
'lLocation,
'1 new *** will be first one in the WB
'2 new *** will be before active ***
'3 new *** will be after active ***
'4 new *** will be last one in the WB
'if bClear = True it will clear the cells of an existing ***
'will return the name of the newly added ***
'-----------------------------------------------------------------

Dim i As Long
Dim bFound As Boolean
Dim objNew*** As Work***
Dim obj*** As Work***
Dim strOld*** As String
Dim strSuppliedSheetName As String
Dim lLastNumber As Long

If bSetScreenUpdating Then
Application.ScreenUpdating = False
End If

str*** = ClearCharsFromString(str***, "*:?/\[]")

If bActivate = False Then
strOld*** = Active***.Name
End If

strSuppliedSheetName = strSheet

'see if the *** already exists
'-------------------------------
For i = 1 To ActiveWorkbook.Sheets.Count
If UCase(Sheets(i).Name) = UCase(strSheet) Then
bFound = True
If bOverwrite Then
'no new *** to add
'-------------------
Sheets(i).Activate
'otherwise there will be an error at the line
'Cells.Clear when a chart is activated
'--------------------------------------------
Sheets(i).Cells(1).Activate
If bClear Then
Cells.Clear
End If
Add*** = str***
If bActivate = False Then
Sheets(strOldSheet).Activate
End If
If bSetScreenUpdating Then
Application.ScreenUpdating = True
End If
Exit Function
End If
End If
Next i

For Each objSheet In ActiveWorkbook.Worksheets
If obj***.Name = str*** Then
bFound = True
Exit For
End If
Next obj***

'*** not in WB yet, or bOverWrite = FALSE, so add
'--------------------------------------------------
Select Case lLocation
Case 1
Set objNew*** = ActiveWorkbook.Sheets.Add(Before:=ActiveWorkbook.Sheets(1))
Case 2
Set objNewSheet = ActiveWorkbook.Sheets.Add 'will be before active ***
Case 3
Set objNewSheet = ActiveWorkbook.Sheets.Add(After:=ActiveSheet)
Case 4
Set objNew*** = ActiveWorkbook.Sheets.Add(After:=Sheets(ActiveWorkbook.Sheets.Count))
End Select

'activate and name it
'--------------------
objNew***.Activate

'truncate if *** name is too long
'----------------------------------
If Len(str***) > 27 Then
str*** = Left$(str***, 27) & "_" & 1
i = 1
Do While SheetExists(Left$(strSheet, 27) & "_" & i) = True
i = i + 1
str*** = Left$(str***, 27) & "_" & i
Loop
End If

If bFound = False Then
Active***.Name = str***
Add*** = str***
Else
If IsNumeric(Right$(str***, 1)) Then
Do While SheetExists(strSheet) = True
lLastNumber = Val(GetLastNumberFromString(str***, "."))
str*** = Left$(str***, Len(str***) - Len(CStr(lLastNumber))) & _
lLastNumber + 1
Loop
Active***.Name = str***
Add*** = str***
Else
i = 2
Do Until SheetExists(strSheet & "_" & i) = False
i = i + 1
Loop
Active***.Name = str*** & "_" & i
Add*** = str*** & "_" & i
End If
End If

If bActivate = False Then
Sheets(strOldSheet).Activate
End If

If bSetScreenUpdating Then
Application.ScreenUpdating = True
End If

End Function

Function ClearCharsFromString(strString As String, _
strChars As String, _
Optional bAll As Boolean = True, _
Optional bLeading As Boolean, _
Optional bTrailing As Boolean) As String

Dim i As Long
Dim strChar As String

ClearCharsFromString = strString

If bAll Then
For i = 1 To Len(strChars)
strChar = Mid$(strChars, i, 1)
If InStr(1, strString, strChar) > 0 Then
ClearCharsFromString = Replace(ClearCharsFromString, _
strChar, _
vbNullString, _
1, -1, vbBinaryCompare)
End If
Next i
Else
If bLeading Then
Do While InStr(1, strChars, Left$(ClearCharsFromString, 1), _
vbBinaryCompare) > 0
ClearCharsFromString = Right$(ClearCharsFromString, _
Len(ClearCharsFromString) - 1)
Loop
End If
If bTrailing Then
Do While InStr(1, strChars, Right$(ClearCharsFromString, 1), _
vbBinaryCompare) > 0
ClearCharsFromString = Left$(ClearCharsFromString, _
Len(ClearCharsFromString) - 1)
Loop
End If
End If

End Function

Function SheetExists(ByVal strSheetName As String) As Boolean

'returns True if the *** exists in the active workbook
'-------------------------------------------------------

Dim x As Object

On Error Resume Next
Set x = ActiveWorkbook.Sheets(strSheetName)

If Err = 0 Then
SheetExists = True
Else
SheetExists = False
End If

End Function

Public Function GetLastNumberFromString(strString As String, _
strSeparator As String) As String

Dim btBytes() As Byte
Dim btSeparator() As Byte
Dim i As Long
Dim c As Long
Dim lLast As Long
Dim lFirst As Long
Dim bFoundDot As Boolean
Dim strNumber As String

btBytes() = strString
btSeparator() = strSeparator

'find the last numeric character
For i = UBound(btBytes) - 1 To 0 Step -2
If btBytes(i) > 47 And btBytes(i) < 58 Then
lLast = i
'find the first numeric character
For c = lLast - 2 To 0 Step -2
If btBytes(c) > 57 Or _
(btBytes(c) < 48 And _
btBytes(c) <> btSeparator(0)) Then
'non-numeric and no separator, so get out
lFirst = c + 2
GoTo GETOUT
End If
If btBytes(c) = btSeparator(0) Then
If bFoundDot = False Then
'first separator, so search for more numbers
bFoundDot = True
Else
'second separator, so get out
lFirst = c + 2
GoTo GETOUT
End If
End If
Next
End If
Next

GETOUT:

'build up the numeric string
For i = lFirst \ 2 + 1 To lLast \ 2 + 1
strNumber = strNumber & Mid$(strString, i, 1)
Next

'add trailing zero if first character is separator
If Left$(strNumber, 1) = strSeparator Then
strNumber = "0" & strNumber
End If

GetLastNumberFromString = strNumber

End Function


RBS


"FrankTimJr" <FrankTimJr@xxxxxxxxxxxxxxxxxxxxxxxxx> wrote in message news:6CD0DB7E-EED2-4FBD-B948-353DB8E7579B@xxxxxxxxxxxxxxxx
Is there any way to tell a macro that when a new *** is added what the
sheet name is instaed of having Excel just give it the next "sheet1"? Other
functions in the macro reference the newly created tab and I'll never be able
to ensure it is ALWAYS "sheet1" before running the macro. I would like to
have the macro automatically give it a name I designate.

"Sheets.Add" is the function.

Any ideas??
Frank

.

Quantcast