Hi,
This code is not working properly, got error messages while running. please , can any one please correct below VBA Code.
Thanking you.
Regards, V K Mouli
Sub test20221130()
'send multiple emails with spreadsheet attachments with a macro
Dim rng As Range, c As Range, AddrRange As Range
Dim i As Long, lastRow As Long, lastRow2 As Long
Dim targetWorkbook As Workbook
Dim objFSO As Object
Dim varTempFolder As Variant, v As Variant
Dim AttFile As String, Dest As String
Dim sh As Worksheet, shMail As Worksheet
Set sh = Sheets("Master")
Set shMail = Sheets("Mail info")
lastRow = sh.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lastRow3 = shMail.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set AddrRange = shMail.Range("A1:C" & lastRow3)
v = sh.Range("A2:Z" & lastRow).Value '<<==== Change last column is needed
Set objFSO = CreateObject("Scripting.FileSystemObject")
varTempFolder = objFSO.GetSpecialFolder(2).Path & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss")
objFSO.CreateFolder (varTempFolder)
Application.ScreenUpdating = False
With CreateObject("scripting.dictionary")
For i = 2 To UBound(v)
If Not .exists(v(i, 1)) Then
.Add v(i, 1), Nothing
With sh
sh.Range("A1").AutoFilter 1, v(i, 1)
Set rng = .AutoFilter.Range
Set targetWorkbook = Workbooks.Add
.UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(Sheets.Count).Range("A1")
AttFile = v(i, 1) & Format(Now, "dd-mm-yyyy- hh-mm-ss") & ".xlsx"
Dest = Application.WorksheetFunction.VLookup(v(i, 1), AddrRange, 2, False)
Dest1 = Application.WorksheetFunction.VLookup(v(i, 1), AddrRange, 3, False)
With targetWorkbook
.ActiveSheet.Columns.AutoFit
.SaveAs varTempFolder & "\" & AttFile
.Close
End With
With CreateObject("Outlook.Application").CreateItem(0)
.To = Dest
.Cc = Dest1
.subject = "Subject"
.Body = "Please find..."
.Attachments.Add varTempFolder & "\" & AttFile
.display 'to show
'.Send 'to send
End With
End With
End If
Next i
End With
sh.Range("A1").AutoFilter
Application.ScreenUpdating = True
objFSO.deletefolder (varTempFolder)
'kill temp file
Kill TempFilePath & TempFileName & FileExtStr
End Sub
This code is not working properly, got error messages while running. please , can any one please correct below VBA Code.
Thanking you.
Regards, V K Mouli
VBA Code:
'send multiple emails with spreadsheet attachments with a macro
Dim rng As Range, c As Range, AddrRange As Range
Dim i As Long, lastRow As Long, lastRow2 As Long
Dim targetWorkbook As Workbook
Dim objFSO As Object
Dim varTempFolder As Variant, v As Variant
Dim AttFile As String, Dest As String
Dim sh As Worksheet, shMail As Worksheet
Set sh = Sheets("Master")
Set shMail = Sheets("Mail info")
lastRow = sh.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lastRow3 = shMail.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set AddrRange = shMail.Range("A1:C" & lastRow3)
v = sh.Range("A2:Z" & lastRow).Value '<<==== Change last column is needed
Set objFSO = CreateObject("Scripting.FileSystemObject")
varTempFolder = objFSO.GetSpecialFolder(2).Path & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss")
objFSO.CreateFolder (varTempFolder)
Application.ScreenUpdating = False
With CreateObject("scripting.dictionary")
For i = 2 To UBound(v)
If Not .exists(v(i, 1)) Then
.Add v(i, 1), Nothing
With sh
sh.Range("A1").AutoFilter 1, v(i, 1)
Set rng = .AutoFilter.Range
Set targetWorkbook = Workbooks.Add
.UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(Sheets.Count).Range("A1")
AttFile = v(i, 1) & Format(Now, "dd-mm-yyyy- hh-mm-ss") & ".xlsx"
Dest = Application.WorksheetFunction.VLookup(v(i, 1), AddrRange, 2, False)
Dest1 = Application.WorksheetFunction.VLookup(v(i, 1), AddrRange, 3, False)
With targetWorkbook
.ActiveSheet.Columns.AutoFit
.SaveAs varTempFolder & "\" & AttFile
.Close
End With
With CreateObject("Outlook.Application").CreateItem(0)
.To = Dest
.Cc = Dest1
.subject = "Subject"
.Body = "Please find..."
.Attachments.Add varTempFolder & "\" & AttFile
.display 'to show
'.Send 'to send
End With
End With
End If
Next i
End With
sh.Range("A1").AutoFilter
Application.ScreenUpdating = True
objFSO.deletefolder (varTempFolder)
'kill temp file
Kill TempFilePath & TempFileName & FileExtStr
End Sub