Problem with macro to email xls

[Guest]

Hi, I've been using a macro to automatically send Excel worksheets to
specific email addresses on quite a few files I have set up. I just added
this macro to a spreadsheet that has some merged cells that are used for
notes. I realized after I began using the macro that any text typed into the
merged cell beyond 250 characters is deleted when the worksheet is emailed
using the macro. I don't believe this is a problem with the code, but I am
including it below to make sure. Is there any work around for this?

Sub Mail_ActiveSheet_PR()
Dim wb As Workbook
Dim strdate As String
strdate = Format(Now, "yymmdd")
Application.ScreenUpdating = False
ActiveSheet.Copy
Set wb = ActiveWorkbook
With wb
.SaveAs "C:\" & Sheets("Dom. Parts Order Req").Range("D11").Value &
" Approved.xls"
.SendMail "(e-mail address removed)", Sheets("Dom. Parts Order
Req").Range("D11").Value
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
Application.ScreenUpdating = True
End Sub

Thanks,
Holly

 

[Ron de Bruin]

The only thing you can do to avoid this Excel bug (btw: fixed in excel 2007) is to
to add a new workbook with one sheet and copy all cells from your sheet in this workbook

Sub Mail_ActiveSheet_PR()
Dim ws As Worksheet
Dim wb As Workbook
Dim strdate As String
strdate = Format(Now, "yymmdd")

Application.ScreenUpdating = False

Set ws = ActiveSheet
Set wb = Workbooks.Add(1)
ws.Cells.Copy wb.Sheets(1).Cells(1)
ws.Name = "Dom. Parts Order Req"

With wb
.SaveAs "C:\" & wb.Sheets(1).Range("D11").Value & " Approved.xls"
.SendMail "(e-mail address removed)", wb.Sheets(1).Range("D11").Value
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
Application.ScreenUpdating = True
End Sub

 

[Guest]

Thanks, Ron.

This worked perfectly. One more question, though. Anyway this can be made
to work on emailing 2 worksheets in a workbook?

Thanks again,
Holly

 

[Ron de Bruin]

Try this one for "sheet1" and "sheet3"

Sub Mail_ActiveSheet_PR()
Dim i As Integer
Dim sh As Worksheet
Dim wb1 As Workbook
Dim wb As Workbook
Dim strdate As String
strdate = Format(Now, "yymmdd")

Application.ScreenUpdating = False

Set wb1 = ThisWorkbook
Set wb = Workbooks.Add(1)
wb.Worksheets.Add after:=wb.Sheets(1)

i = 0

For Each sh In wb1.Sheets(Array("Sheet1", "Sheet3"))
i = i + 1
sh.Cells.Copy wb.Sheets(i).Cells(1)
Next sh

With wb
.SaveAs "C:\" & wb.Sheets(1).Range("D11").Value & " Approved.xls"
.SendMail "(e-mail address removed)", wb.Sheets(1).Range("D11").Value
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
Application.ScreenUpdating = True
End Sub

 

[Ron de Bruin]

This one is easier and also have the correct sheet names

Sub Mail_ActiveSheet_PR()
Dim sh As Worksheet
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim strdate As String
strdate = Format(Now, "yymmdd")

Application.ScreenUpdating = False

Set wb1 = ThisWorkbook

wb1.Sheets(Array("Sheet1", "Sheet3")).Copy
Set wb2 = ActiveWorkbook

For Each sh In wb2.Worksheets
wb1.Sheets(sh.Name).Cells.Copy wb2.Sheets(sh.Name).Cells(1)
Next sh

With wb2
.SaveAs "C:\" & wb2.Sheets(1).Range("D11").Value & " Approved.xls"
.SendMail "(e-mail address removed)", wb2.Sheets(1).Range("D11").Value
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
Application.ScreenUpdating = True
End Sub

 

[Guest]

Thank you so much! This is excellent.

This one is easier and also have the correct sheet names

Sub Mail_ActiveSheet_PR()
Dim sh As Worksheet
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim strdate As String
strdate = Format(Now, "yymmdd")

Application.ScreenUpdating = False

Set wb1 = ThisWorkbook

wb1.Sheets(Array("Sheet1", "Sheet3")).Copy
Set wb2 = ActiveWorkbook

For Each sh In wb2.Worksheets
wb1.Sheets(sh.Name).Cells.Copy wb2.Sheets(sh.Name).Cells(1)
Next sh

With wb2
.SaveAs "C:\" & wb2.Sheets(1).Range("D11").Value & " Approved.xls"
.SendMail "(e-mail address removed)", wb2.Sheets(1).Range("D11").Value
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
Application.ScreenUpdating = True
End Sub