zmasterdevil
New Member
- Joined
- Dec 5, 2022
- Messages
- 11
- Office Version
- 365
- Platform
- Windows
Hi Everybody,
I use a macro to do the following: It copies the current, active worksheet into a new workbook, names it, then prepares an email with the newly made workbook as the attachment. The new workbook is just temporary and for the email only. This macro is cobbled together from other people's code, as my coding skills are bad to non-existent. It works for single worksheet accounts, but some of my accounts have multiple sheets. I need to edit it so that it can copy multiple worksheets from the current workbook to make a new workbook. The tabs (or worksheets) that will be copied into the new workbook will be the same every time, so naming the tabs in the code will work fine.
I know this code probably already exists somewhere, but I've been searching for quite a while, and haven't found anything that I could get to work. I've pasted the code I'm using for creating and emailing single sheet workbooks below. Can anyone help me edit it to work for multiple sheets from the same original workbook? I appreciate any help that can be given.
Sub EmailActiveSheet_Distribution_1_540()
Dim OutApp As Object
Dim OutMail As Object
Dim TempFilePath As String
Dim FileExt As String
Dim TempFileName As String
Dim FileFullPath As String
Dim FileFormat As Variant
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim strbody As String
Dim mySubject1 As Variant
Dim myBody1 As Variant
mySubject1 = Worksheets("540 Control Sheet").Range("D28").Value
myBody1 = Worksheets("540 Control Sheet").Range("D29").Value
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Wb1 = ThisWorkbook
ActiveSheet.Copy
Set Wb2 = ActiveWorkbook
'Below code will get the File Extension and
'the file format which we want to save the copy
'of the workbook with the active sheet.
With Wb2
If Val(Application.Version) < 12 Then
FileExt = ".xls": FileFormat = -4143
Else
Select Case Wb1.FileFormat
Case 51: FileExt = ".xlsx": FileFormat = 51
Case 52:
If .HasVBProject Then
FileExt = ".xlsm": FileFormat = 52
Else
FileExt = ".xlsx": FileFormat = 51
End If
Case 56: FileExt = ".xls": FileFormat = 56
Case Else: FileExt = ".xlsb": FileFormat = 50
End Select
End If
End With
'Save your workbook in your temp folder of your system
'below code gets the full path of the temporary folder
'in your system
TempFilePath = Environ$("temp") & "\"
'Now append a date and time stamp
'in your new file
TempFileName = Range("Z2").Value & " " & Format(Now + 31, "mmmm yyyy")
'Complete path of the file where it is saved
FileFullPath = TempFilePath & TempFileName & FileExt
'Now save your currect workbook at the above path
Wb2.SaveAs FileFullPath, FileFormat:=FileFormat
'Now open a new mail
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<Body style = font-size:12pt;font-family:Ariel>" & "Hi " & _
Range("z1").Value & ",<br><br>" & myBody1 & "<br><br>"
On Error Resume Next
With OutMail
.To = Range("Z3")
For Each cel In Range("z4:af4")
Dim sCC As String
sCC = sCC & ";" & cel.Value2
Next
.CC = Mid(sCC, 2) 'to cut off initial ";"
.Subject = Range("Z2") & " " & mySubject1
.htmlBody = strbody & _
"<img src='MY EMAIL SIGNATURE FILE'>" & .htmlBody
.Display
.Attachments.Add FileFullPath '--- full path of the temp file where it is saved
.Display 'use .Display or .Send depending on need
End With
On Error GoTo 0
'Since mail has been sent with the attachment
'Now close and delete the temp file from the
'temp folder
Wb2.Close SaveChanges:=False
Kill FileFullPath
'set nothing to the objects created
Set OutMail = Nothing
Set OutApp = Nothing
'Now set the application properties back to true
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
I use a macro to do the following: It copies the current, active worksheet into a new workbook, names it, then prepares an email with the newly made workbook as the attachment. The new workbook is just temporary and for the email only. This macro is cobbled together from other people's code, as my coding skills are bad to non-existent. It works for single worksheet accounts, but some of my accounts have multiple sheets. I need to edit it so that it can copy multiple worksheets from the current workbook to make a new workbook. The tabs (or worksheets) that will be copied into the new workbook will be the same every time, so naming the tabs in the code will work fine.
I know this code probably already exists somewhere, but I've been searching for quite a while, and haven't found anything that I could get to work. I've pasted the code I'm using for creating and emailing single sheet workbooks below. Can anyone help me edit it to work for multiple sheets from the same original workbook? I appreciate any help that can be given.
Sub EmailActiveSheet_Distribution_1_540()
Dim OutApp As Object
Dim OutMail As Object
Dim TempFilePath As String
Dim FileExt As String
Dim TempFileName As String
Dim FileFullPath As String
Dim FileFormat As Variant
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim strbody As String
Dim mySubject1 As Variant
Dim myBody1 As Variant
mySubject1 = Worksheets("540 Control Sheet").Range("D28").Value
myBody1 = Worksheets("540 Control Sheet").Range("D29").Value
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Wb1 = ThisWorkbook
ActiveSheet.Copy
Set Wb2 = ActiveWorkbook
'Below code will get the File Extension and
'the file format which we want to save the copy
'of the workbook with the active sheet.
With Wb2
If Val(Application.Version) < 12 Then
FileExt = ".xls": FileFormat = -4143
Else
Select Case Wb1.FileFormat
Case 51: FileExt = ".xlsx": FileFormat = 51
Case 52:
If .HasVBProject Then
FileExt = ".xlsm": FileFormat = 52
Else
FileExt = ".xlsx": FileFormat = 51
End If
Case 56: FileExt = ".xls": FileFormat = 56
Case Else: FileExt = ".xlsb": FileFormat = 50
End Select
End If
End With
'Save your workbook in your temp folder of your system
'below code gets the full path of the temporary folder
'in your system
TempFilePath = Environ$("temp") & "\"
'Now append a date and time stamp
'in your new file
TempFileName = Range("Z2").Value & " " & Format(Now + 31, "mmmm yyyy")
'Complete path of the file where it is saved
FileFullPath = TempFilePath & TempFileName & FileExt
'Now save your currect workbook at the above path
Wb2.SaveAs FileFullPath, FileFormat:=FileFormat
'Now open a new mail
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<Body style = font-size:12pt;font-family:Ariel>" & "Hi " & _
Range("z1").Value & ",<br><br>" & myBody1 & "<br><br>"
On Error Resume Next
With OutMail
.To = Range("Z3")
For Each cel In Range("z4:af4")
Dim sCC As String
sCC = sCC & ";" & cel.Value2
Next
.CC = Mid(sCC, 2) 'to cut off initial ";"
.Subject = Range("Z2") & " " & mySubject1
.htmlBody = strbody & _
"<img src='MY EMAIL SIGNATURE FILE'>" & .htmlBody
.Display
.Attachments.Add FileFullPath '--- full path of the temp file where it is saved
.Display 'use .Display or .Send depending on need
End With
On Error GoTo 0
'Since mail has been sent with the attachment
'Now close and delete the temp file from the
'temp folder
Wb2.Close SaveChanges:=False
Kill FileFullPath
'set nothing to the objects created
Set OutMail = Nothing
Set OutApp = Nothing
'Now set the application properties back to true
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
