kamdardharmesh
New Member
I was using following macro and was sending attachment through mail. but today, it has given following error
Array index out of bound - Run time error 440.
While deleting attachments of previous mail, it throws error.
Specific part of error is as under.
For x = 1 To .Item.Attachments.Count
.Item.Attachments(x).Delete
Next x
Pls help in resolving the same.
Entire code is as under.
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 5
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
For x = 1 To .Item.Attachments.Count
.Item.Attachments(x).Delete
Next x
' Set the optional introduction field thats adds
' some header text to the email body.
'.Introduction = "This is test mail 2."
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
Array index out of bound - Run time error 440.
While deleting attachments of previous mail, it throws error.
Specific part of error is as under.
For x = 1 To .Item.Attachments.Count
.Item.Attachments(x).Delete
Next x
Pls help in resolving the same.
Entire code is as under.
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 5
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
For x = 1 To .Item.Attachments.Count
.Item.Attachments(x).Delete
Next x
' Set the optional introduction field thats adds
' some header text to the email body.
'.Introduction = "This is test mail 2."
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