How to create individual sheets from one sheet and email them individually

I need a macro for send individual sheet as attachment from a worksheet to email outlook address based on emails (column F) in the attached sample file. Automatically email has to go for all the individual sheets by separate emails.

Let me know if you need any details.

Thanks so much in advance.Sample.xlsx

Hi...

I want to send an attachment(not entire sheet, only each individual details) to each individual listed in Column F of Sheet1.

Hi John,

Weekly basis, I will download this data from SAP (Attached: Sample.xlsx)

I need a macro for to separate the data according to Personnel no. (Column A) in separate each excel and automatically needs to send an email to each individual personnel no. to respectively email (Column F) with attachment.

Attached Sample files:
112537.xlsx
113214.xlsx
203047.xlsx

Sample email i have sent to your email id as attachment..

Let me know if you want any information

Thanks in advance....

Shoju

Thanks to all..

I wrote vba code for the above.. Now its working perfectly for the attachment sample data...

VBA Code:

Sub SeparateToSheets()
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
Dim LastRow As Long

LastRow = Range("A" & ws.Rows.Count).End(xlUp).Row

' stop processing if we don't have any data
If LastRow < 2 Then Exit Sub

Application.ScreenUpdating = False
SortMasterList LastRow, ws
CopyDataToSheets LastRow, ws
ws.Select
ActiveWindow.SelectedSheets.Delete
Application.ScreenUpdating = True

' Mail send to User with attachment

Call MailtoSend
End Sub

Sub SortMasterList(LastRow As Long, ws As Worksheet)
ws.Range("A2:M" & LastRow).Sort Key1:=ws.Range("A1"), Key2:=ws.Range("B1")
End Sub

Sub CopyDataToSheets(LastRow As Long, src As Worksheet)
Dim rng As Range
Dim cell As Range
Dim Series As String
Dim SeriesStart As Long
Dim SeriesLast As Long

Set rng = Range("A2:A" & LastRow)
SeriesStart = 2
Series = Range("A" & SeriesStart).Value
For Each cell In rng
If cell.Value <> Series Then
SeriesLast = cell.Row - 1
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
Series = cell.Value
SeriesStart = cell.Row
End If
Next
' copy the last series
SeriesLast = LastRow
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series

End Sub

Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, name As String)
Dim tgt As Worksheet

If (SheetExists(name)) Then
MsgBox "Sheet " & name & " already exists. " _
& "Please delete or move existing sheets before" _
& " copying data from the Master Sheet.", vbCritical, _
"Duplicate"
End
End If

Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = name
Set tgt = Sheets(name)

' copy header row from src to tgt
tgt.Range("A1:M1").Value = src.Range("A1:M1").Value

' copy data from src to tgt
tgt.Range("A2:M" & Last - Start + 2).Value = _
src.Range("A" & Start & ":M" & Last).Value

End Sub

Function SheetExists(name As String) As Boolean
Dim ws As Worksheet

SheetExists = True
On Error Resume Next
Set ws = Sheets(name)
If ws Is Nothing Then
SheetExists = False
End If
End Function

Sub MailtoSend()
Dim onePublishObject As PublishObject
Dim oneSheet As Worksheet
Dim scriptingObject As Object
Dim outlookApplication As Object
Dim outlookMail As Object
Dim htmlBody As String
Dim htmlFile As String
Dim textStream, fil As String
Dim dummy As Workbook


Today = Format(Now(), "dd-mm-yyyy")

Set dummy = ActiveWorkbook
Set scriptingObject = CreateObject("Scripting.FileSystemObject")
Set outlookApplication = CreateObject("Outlook.Application")
For Each oneSheet In ActiveWorkbook.Worksheets

Dim StrBody As String
Dim strTo As String

strTo = oneSheet.name
StrBody = " THIS IS A TEST" & " " & UCase(oneSheet.name) & " " & "XYZ," & vbNewLine & _
vbNewLine & _
"Please FIND ATTACHED <B>'XYZ REPORT'<B>"


Application.DisplayAlerts = False
Sheets(oneSheet.name).Copy
ActiveWorkbook.SaveAs dummy.Path & "\" & oneSheet.name & ".xlsx"
ActiveWorkbook.Close
Application.DisplayAlerts = True
Set outlookMail = outlookApplication.CreateItem(0)
With outlookMail
.To = strTo
.htmlBody = StrBody & htmlBody
.attachments.Add dummy.Path & "\" & oneSheet.name & ".xlsx"
.Display
.Subject = "XYZ Report" & " " & UCase(oneSheet.name) & " " & "(" & Today & ")"
'.Send
End With
Next oneSheet
End Sub

No.. i never used the site from Ron de Bruin...

Please Login or Register  to view this content.