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