Rename active sheet to contents of specific cell

[burl_rfc]

The following code sends the active sheet to a group of individuals
automatically via e-mail. . Two of the individuals will always receive
the e-mail, the third would depend upon which individual requested the
data, the third individuals name is called from a lookup table and the
corresponding e-mail address is placed into cell I10.

What I'd like to happen is that the active sheet is renamed to the
reference no. in cell B6, this sheet is then e-mailed to the
recipients. The macro works great with the exception of the renaming of
the sheet, is their a simple solution that can remedy this.

Thanks
Burl

Sub Rectangle15_Click()
Dim sh As Worksheet
Dim wb As Workbook
Dim strdate As String
Dim MyArrIndex As Long
Dim E_Mail_Count As Long
Dim cell As Range
Dim MyArr() As String
Application.ScreenUpdating = False
Worksheets("QuoteForm").Activate
Range("I10").Select
Selection.Copy
Range("L2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
For Each sh In ThisWorkbook.Worksheets
If sh.Range("L1").Value Like "?*@?*.?*" Then
strdate = Format(Now, "dd-mm-yy h-mm-ss")

E_Mail_Count =
sh.Columns("L").Cells.SpecialCells(xlCellTypeConstants).Count
ReDim MyArr(1 To E_Mail_Count)
MyArrIndex = 1
For Each cell In
sh.Columns("L").Cells.SpecialCells(xlCellTypeConstants)
If cell Like "*@*" Then
MyArr(MyArrIndex) = cell.Value
MyArrIndex = MyArrIndex + 1
End If
Next
ReDim Preserve MyArr(1 To MyArrIndex)

sh.Copy
Set wb = ActiveWorkbook
ActiveSheet.Name = Range("b6")
With wb
.SaveAs " " & sh.Name & " " & strdate & ".xls"
.SendMail MyArr, _
"New Quote"
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With

End If
Next sh
Application.ScreenUpdating = True
Worksheets("Quote Data Entry").Activate
End Sub

 

[burl_rfc]

I fixed it.......

By changing the following:-

ActiveSheet.Name = Range("b6")
to
sh.name = Range("b6")

Thanks
Burl

 

[burl_rfc]

Maybe I still have a problem.....

Renaming the sheet according to the contents of cell "B6" may not be
the best solution. The original name of the sheet I need to maintain (I
use the original sheet name to make it the active sheet at the begining
of the macro, renaming the sheet would only complicate things later).

Could I perhaps save the sheet using the contents of cell "B6" as the
name of the file along with the strdate instead of renaming the sheet.

Thanks
Burl

sh.Copy
Set wb = ActiveWorkbook
ActiveSheet.Name = Range("b6")
With wb
.SaveAs " " & sh.Name & " " & strdate & ".xls"
.SendMail MyArr, _
"New Quote"
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With

 

[burl_rfc]

Okay, now it's working fine...

I added the renaming of the sheet to the next to last step in the
macro, I'm thinking that where I had previously put it, it was causing
some problems. The finish code is below


Sub Rectangle15_Click()
Dim sh As Worksheet
Dim wb As Workbook
Dim strdate As String
Dim MyArrIndex As Long
Dim E_Mail_Count As Long
Dim cell As Range
Dim MyArr() As String
Application.ScreenUpdating = False
Worksheets("QuoteForm").Activate
Range("I10").Select
Selection.Copy
Range("L2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
For Each sh In ThisWorkbook.Worksheets
If sh.Range("L1").Value Like "?*@?*.?*" Then
strdate = Format(Now, "dd-mm-yy h-mm-ss")

E_Mail_Count =
sh.Columns("L").Cells.SpecialCells(xlCellTypeConstants).Count
ReDim MyArr(1 To E_Mail_Count)
MyArrIndex = 1
For Each cell In
sh.Columns("L").Cells.SpecialCells(xlCellTypeConstants)
If cell Like "*@*" Then
MyArr(MyArrIndex) = cell.Value
MyArrIndex = MyArrIndex + 1
End If
Next
ReDim Preserve MyArr(1 To MyArrIndex)

sh.Copy
Set wb = ActiveWorkbook
sh.Name = Range("b6")
With wb
.SaveAs " " & sh.Name & " " & strdate & ".xls"
.SendMail MyArr, _
"New Quote"
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With

End If

Next sh

Application.ScreenUpdating = True
ActiveSheet.Name = "QuoteForm"
Worksheets("Quote Data Entry").Activate
End Sub