C
carl
I have been using the code below to send a selection of a
worksheet based on filtering on email destinations. I
would like to enhance the feature to have more than 1
email address in column K. For example
jsmith@companya,rsmith@companya,jroberts@companya.
Here's the code:
Sub Mail_Selection2()
Dim source As Range
Dim dest As Workbook
Dim strdate As String
Dim cell As Range
Dim str As String
Set source = Nothing
On Error Resume Next
Set source = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If source Is Nothing Then
MsgBox "The source is not a range or the sheet is
protect, please correct and try again.", vbOKOnly
Exit Sub
End If
If ActiveWindow.SelectedSheets.Count > 1 Or _
Selection.Cells.Count = 1 Or _
Selection.Areas.Count > 1 Then
MsgBox "An Error occurred :" & vbNewLine &
vbNewLine & _
"You have more than one sheet selected." &
vbNewLine & _
"You only selected one cell." & vbNewLine &
_
"You selected more than one area." &
vbNewLine & vbNewLine & _
"Please correct and try again.", vbOKOnly
Exit Sub
End If
Application.ScreenUpdating = False
For Each cell In Columns("K").Cells.SpecialCells
(xlCellTypeFormulas)
If cell.EntireRow.Hidden = False And cell.Value
Like "*@*" Then
str = cell.Value
Exit For
End If
Next cell
Set dest = Workbooks.Add(xlWBATWorksheet)
source.Copy
With dest.Sheets(1)
.Cells(1).PasteSpecial paste:=8
' Paste:=8 will copy the column width in Excel
2000 and higher
' If you use Excel 97 use the other example
.Cells(1).PasteSpecial xlPasteValues, , False,
False
.Cells(1).PasteSpecial xlPasteFormats, , False,
False
.Cells(1).Select
Application.CutCopyMode = False
End With
strdate = Format(Now, "dd-mm-yy h-mm-ss")
With dest
.SaveAs "Selection of " & ThisWorkbook.Name _
& " " & strdate & ".xls"
.SendMail str, _
"This is the Subject line"
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
Application.ScreenUpdating = True
End Sub
worksheet based on filtering on email destinations. I
would like to enhance the feature to have more than 1
email address in column K. For example
jsmith@companya,rsmith@companya,jroberts@companya.
Here's the code:
Sub Mail_Selection2()
Dim source As Range
Dim dest As Workbook
Dim strdate As String
Dim cell As Range
Dim str As String
Set source = Nothing
On Error Resume Next
Set source = Selection.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If source Is Nothing Then
MsgBox "The source is not a range or the sheet is
protect, please correct and try again.", vbOKOnly
Exit Sub
End If
If ActiveWindow.SelectedSheets.Count > 1 Or _
Selection.Cells.Count = 1 Or _
Selection.Areas.Count > 1 Then
MsgBox "An Error occurred :" & vbNewLine &
vbNewLine & _
"You have more than one sheet selected." &
vbNewLine & _
"You only selected one cell." & vbNewLine &
_
"You selected more than one area." &
vbNewLine & vbNewLine & _
"Please correct and try again.", vbOKOnly
Exit Sub
End If
Application.ScreenUpdating = False
For Each cell In Columns("K").Cells.SpecialCells
(xlCellTypeFormulas)
If cell.EntireRow.Hidden = False And cell.Value
Like "*@*" Then
str = cell.Value
Exit For
End If
Next cell
Set dest = Workbooks.Add(xlWBATWorksheet)
source.Copy
With dest.Sheets(1)
.Cells(1).PasteSpecial paste:=8
' Paste:=8 will copy the column width in Excel
2000 and higher
' If you use Excel 97 use the other example
.Cells(1).PasteSpecial xlPasteValues, , False,
False
.Cells(1).PasteSpecial xlPasteFormats, , False,
False
.Cells(1).Select
Application.CutCopyMode = False
End With
strdate = Format(Now, "dd-mm-yy h-mm-ss")
With dest
.SaveAs "Selection of " & ThisWorkbook.Name _
& " " & strdate & ".xls"
.SendMail str, _
"This is the Subject line"
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close False
End With
Application.ScreenUpdating = True
End Sub