VBA to email each sheet in a workbook

[leemcder]

VBA to email each sheet in a workbook
Hi, could someone please do me a huge favour and help me with this. I want to be able to email each sheet in a workbook, I have hundreds of sheets and need to email each one individually. Each sheet will have a colleagues name in cell A2, and I want that sheet to be emailed to the person in cell A2. I can create a sheet called Mailinfo with colleague names in row A and their email addresses in row B. Can anyone come up with a VBA that would do this? your help would be much appreciated.

Many Thanks

[Logit]

https://www.rondebruin.nl/win/s1/outlook/mail.htm

[leemcder]

Thanks, I found pretty much what I was looking for, but I can anyone tell me what lines I need to add/amend so if a person is receiving more than 1 sheet, they will only get 1 email with each attachment and not say 10 emails. I will be emailing hundreds of sheets to several people but I just want each person to receive 1 email each containing all their attachments. I also want to have a sheet called Mailinfo containing all my colleagues names and email addresses, so their names will be in cell A1 of each sheet and the email will be sent to that person. Can anyone help with this?

Sub Mail_Every_Worksheet()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
TempFilePath = Environ$("temp") & ""
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsm": FileFormatNum = 52
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
For Each sh In ThisWorkbook.Worksheets
If sh.Range("A2").Value Like "?*@?*.?*" Then
sh.Copy
Set wb = ActiveWorkbook
TempFileName = "Sheet " & sh.Name & " of " _
& ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutMail = OutApp.CreateItem(0)
With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = sh.Range("A2").Value
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With

Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If
Next sh
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub