veve3
03-25-2015, 04:07 AM
Hi,
I have big file which I divided using module1. This modul separate file by same content in destined column.
Now I have many sheets which I need sent to different email adress. I looked up module2 which will be on every sheet and manualy can sent sheet to adress in cell AJ2. How I need to modifymodule2 to send all sheets to address AJ2 (each sheet has a different value AJ2). Thank you very very much.
module1
Dim title As String
Dim titlerow As Integer
vcol = 4
Set ws = Sheets("0215")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A:AI"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCel lTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate End Submodule2
Sub Email_Sheet()
Dim oApp As Object
Dim oMail As Object
Dim LWorkbook As Workbook
Dim LFileName As String
'Turn off screen updating
Application.ScreenUpdating = False
'Copy the active worksheet and save to a temporary workbook
ActiveSheet.Copy
Set LWorkbook = ActiveWorkbook
'Create a temporary file in your current directory that uses the name
' of the sheet as the filename
LFileName = LWorkbook.Worksheets(1).Name
On Error Resume Next
'Delete the file if it already exists
Kill LFileName
On Error GoTo 0
'Save temporary file
LWorkbook.SaveAs Filename:=LFileName
'Create an Outlook object and new mail message
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
'Set mail attributes (uncomment lines to enter attributes)
' In this example, only the attachment is being added to the mail message
With oMail
.To = Range("AJ2")
.Subject = "Name"
.body = "This is the body of the message." & vbCrLf & vbCrLf & _
"Attached is the file"
.Attachments.Add LWorkbook.FullName
.Display
End With
'Delete the temporary file and close temporary Workbook
LWorkbook.ChangeFileAccess Mode:=xlReadOnly
Kill LWorkbook.FullName
LWorkbook.Close SaveChanges:=False
'Turn back on screen updating
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing
End Sub
I have big file which I divided using module1. This modul separate file by same content in destined column.
Now I have many sheets which I need sent to different email adress. I looked up module2 which will be on every sheet and manualy can sent sheet to adress in cell AJ2. How I need to modifymodule2 to send all sheets to address AJ2 (each sheet has a different value AJ2). Thank you very very much.
module1
Dim title As String
Dim titlerow As Integer
vcol = 4
Set ws = Sheets("0215")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A:AI"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCel lTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate End Submodule2
Sub Email_Sheet()
Dim oApp As Object
Dim oMail As Object
Dim LWorkbook As Workbook
Dim LFileName As String
'Turn off screen updating
Application.ScreenUpdating = False
'Copy the active worksheet and save to a temporary workbook
ActiveSheet.Copy
Set LWorkbook = ActiveWorkbook
'Create a temporary file in your current directory that uses the name
' of the sheet as the filename
LFileName = LWorkbook.Worksheets(1).Name
On Error Resume Next
'Delete the file if it already exists
Kill LFileName
On Error GoTo 0
'Save temporary file
LWorkbook.SaveAs Filename:=LFileName
'Create an Outlook object and new mail message
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
'Set mail attributes (uncomment lines to enter attributes)
' In this example, only the attachment is being added to the mail message
With oMail
.To = Range("AJ2")
.Subject = "Name"
.body = "This is the body of the message." & vbCrLf & vbCrLf & _
"Attached is the file"
.Attachments.Add LWorkbook.FullName
.Display
End With
'Delete the temporary file and close temporary Workbook
LWorkbook.ChangeFileAccess Mode:=xlReadOnly
Kill LWorkbook.FullName
LWorkbook.Close SaveChanges:=False
'Turn back on screen updating
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing
End Sub