kamdardharmesh
New Member
I am using following macro for sending two attachments in one mail.
But in first mail, two attachments are going. In second mail, 4 attachments are going and so on. How to remove earlier attachments? My code is as under.
Pls help.
Regards,
Dharmesh Kamdar
Sub drkthree()
'
' dkthree Macro
'
'
Set fs = CreateObject("Scripting.FileSystemObject"
fs.DeleteFile "D:dataPortfolioMacroLostCustomers.xls", force
fs.DeleteFile "D:dataPortfolioMacroTopCustomers.xls", force
For i = 1 To 50
Range("P1"
= i
Range("A6"
.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Columns("K:K"
.Select
Selection.ColumnWidth = 22.71
Range("J:J,L:M"
.Select
Range("L1"
.Activate
Selection.ColumnWidth = 10.14
Selection.ColumnWidth = 11
Application.CutCopyMode = False
Selection.NumberFormat = "[$-409]d-mmm-yy;@"
ActiveWindow.DisplayGridlines = False
Range("A1"
.Select
Application.DisplayAlerts = False
Columns("A:Q"
.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("P11"
.Select
Application.CutCopyMode = False
Columns("A:Q"
.Select
Selection.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
"D:dataPortfolioMacroLostCustomers.xls", FileFormat:= _
xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWindow.Close
Application.DisplayAlerts = True
'14Aug13
Range("A22"
.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Columns("H:H"
.Select
Selection.ColumnWidth = 22.71
Range("G:G,I:J"
.Select
Range("I1"
.Activate
Selection.ColumnWidth = 10.14
Selection.ColumnWidth = 11
Application.CutCopyMode = False
Selection.NumberFormat = "[$-409]d-mmm-yy;@"
ActiveWindow.DisplayGridlines = False
Range("A1"
.Select
Application.DisplayAlerts = False
Columns("A:Q"
.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("P11"
.Select
Application.CutCopyMode = False
Columns("A:Q"
.Select
Selection.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
"D:dataPortfolioMacroTopCustomers.xls", FileFormat:= _
xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWindow.Close
Application.DisplayAlerts = True
'14 Aug 13
'End Sub
'Sub drktwo()
'
Dim AWorksheet As Worksheet
Dim Sendrng As Range
Dim rng As Range
On Error GoTo StopMacro
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Fill in the Worksheet/range you want to mail
'Note: if you use one cell it will send the whole worksheet
Set Sendrng = Worksheets("Sheet4"
.Range("A1:N69"
'Remember the activesheet
Set AWorksheet = ActiveSheet
With Sendrng
' Select the worksheet with the range you want to send
.Parent.Select
'Remember the ActiveCell on that worksheet
Set rng = ActiveCell
'Select the range you want to mail
.Select
' Create the mail and send it
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
With .Item
.to = Range("R1"
.CC = Range("S1"
'.BCC = ""
.Subject = Range("Q2"
.Attachments.Add "D:dataPortfolioMacroLostCustomers.xls"
.Attachments.Add "D:dataPortfolioMacroTopCustomers.xls"
.Send
' Set fs = CreateObject("Scripting.FileSystemObject"
' fs.DeleteFile "C:Usersdharmesh4033DesktopPortfolioMacroCustomers.xls", force
End With
End With
'select the original ActiveCell
rng.Select
End With
'Activate the sheet that was active before you run the macro
AWorksheet.Select
StopMacro:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveWorkbook.EnvelopeVisible = False
Next i
End Sub
But in first mail, two attachments are going. In second mail, 4 attachments are going and so on. How to remove earlier attachments? My code is as under.
Pls help.
Regards,
Dharmesh Kamdar
Sub drkthree()
'
' dkthree Macro
'
'
Set fs = CreateObject("Scripting.FileSystemObject"
fs.DeleteFile "D:dataPortfolioMacroLostCustomers.xls", force
fs.DeleteFile "D:dataPortfolioMacroTopCustomers.xls", force
For i = 1 To 50
Range("P1"
Range("A6"
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Columns("K:K"
Selection.ColumnWidth = 22.71
Range("J:J,L:M"
Range("L1"
Selection.ColumnWidth = 10.14
Selection.ColumnWidth = 11
Application.CutCopyMode = False
Selection.NumberFormat = "[$-409]d-mmm-yy;@"
ActiveWindow.DisplayGridlines = False
Range("A1"
Application.DisplayAlerts = False
Columns("A:Q"
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("P11"
Application.CutCopyMode = False
Columns("A:Q"
Selection.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
"D:dataPortfolioMacroLostCustomers.xls", FileFormat:= _
xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWindow.Close
Application.DisplayAlerts = True
'14Aug13
Range("A22"
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Columns("H:H"
Selection.ColumnWidth = 22.71
Range("G:G,I:J"
Range("I1"
Selection.ColumnWidth = 10.14
Selection.ColumnWidth = 11
Application.CutCopyMode = False
Selection.NumberFormat = "[$-409]d-mmm-yy;@"
ActiveWindow.DisplayGridlines = False
Range("A1"
Application.DisplayAlerts = False
Columns("A:Q"
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("P11"
Application.CutCopyMode = False
Columns("A:Q"
Selection.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
"D:dataPortfolioMacroTopCustomers.xls", FileFormat:= _
xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
ActiveWindow.Close
Application.DisplayAlerts = True
'14 Aug 13
'End Sub
'Sub drktwo()
'
Dim AWorksheet As Worksheet
Dim Sendrng As Range
Dim rng As Range
On Error GoTo StopMacro
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Fill in the Worksheet/range you want to mail
'Note: if you use one cell it will send the whole worksheet
Set Sendrng = Worksheets("Sheet4"
'Remember the activesheet
Set AWorksheet = ActiveSheet
With Sendrng
' Select the worksheet with the range you want to send
.Parent.Select
'Remember the ActiveCell on that worksheet
Set rng = ActiveCell
'Select the range you want to mail
.Select
' Create the mail and send it
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
With .Item
.to = Range("R1"
.CC = Range("S1"
'.BCC = ""
.Subject = Range("Q2"
.Attachments.Add "D:dataPortfolioMacroLostCustomers.xls"
.Attachments.Add "D:dataPortfolioMacroTopCustomers.xls"
.Send
' Set fs = CreateObject("Scripting.FileSystemObject"
' fs.DeleteFile "C:Usersdharmesh4033DesktopPortfolioMacroCustomers.xls", force
End With
End With
'select the original ActiveCell
rng.Select
End With
'Activate the sheet that was active before you run the macro
AWorksheet.Select
StopMacro:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveWorkbook.EnvelopeVisible = False
Next i
End Sub