Save and Email VBA code for my current active worksheet - vba

Sub Mail_ActiveSheet()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "MyFilename " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = ""
.CC = ""
.BCC = ""
.Subject = "MyFilename" & Format(Now, "dd-mmm-yy")
.Body = ""
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
I already have a piece of code that will save and email my active worksheet. but what i would like to know is if i've got a date in, for example, cell T29 of the active worksheet being sent, how would I add that date to my export filename instead of the format(now, ddmmyyy) line?

To get the date from T29, then something like this is needed:
Format(Range("T29"),"DDMMYYY")
If you want to get the date from T29 of a specific worksheet, then you should specify the worksheet as well - Format(WorkSheets("SomeName").Range("T29"),"DDMMYYY"). If you do not specify the worksheet, it takes the one which is selected.

Related

Excel VBA macro send a selection of current workbook as attachment to an email

I need to send only a selection of the active workbook as an attachment in an email to some recipients.
How do I modify below's code in order to send only a selected range of the current workbook?
Below's code works completely fine but sends the complete active workbook. How do I send the range of A1:M35 ?
Appreciate your help!
Sub Mail_to_recipients()
Dim OutApp As Object
Dim OutMail As Object
Dim myDataRng As Range
Dim cell As Range
Dim iCnt As Integer
Dim sMail_ids As String
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
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 = Wb1.Name & "-" & Format(Now, "dd-mmm-yy h-mm-ss")
'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
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set myDataRng = Range("AJ5:AJ10" & Cells(Rows.Count, "AJ").End(xlUp).Row)
' Run a loop to extract email ids from the 2nd column.
For Each cell In myDataRng
If Trim(sMail_ids) = "" Then
sMail_ids = cell.Offset(1, 0).Value
Else
sMail_ids = sMail_ids & vbCrLf & ";" & cell.Offset(1, 0).Value
End If
Next cell
Set myDataRng = Nothing ' Clear the range.
On Error Resume Next
With OutMail
.To = sMail_ids
.CC = ""
.BCC = ""
.Subject = "Weekindeling week " & Range("K1")
.Attachments.Add FileFullPath
.Display
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
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
The following code will create a new workbook with one sheet, copy the range A1:M35 of the active sheet of the workbook the code is in to the new workbook and email the new workbook as an attachment.
Sub Mail_to_recipients()
Dim OutApp As Object
Dim OutMail As Object
Dim myDataRng As Range
Dim cell As Range
Dim iCnt As Integer
Dim sMail_ids As String
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
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Wb1 = ThisWorkbook
Set Wb2 = Workbooks.Add(xlWBATWorksheet)
Wb1.ActiveSheet.Range("A1:M35").Copy Wb2.Sheets(1).Range("A1")
Wb2.Sheets(1).Name = Wb1.ActiveSheet.Name
'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 = Wb1.Name & "-" & Format(Now, "dd-mmm-yy h-mm-ss")
'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
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set myDataRng = Wb1.ActiveSheet.Range("AJ5:AJ10" & Cells(Rows.Count, "AJ").End(xlUp).Row)
' Run a loop to extract email ids from the 2nd column.
For Each cell In myDataRng
If Trim(sMail_ids) = "" Then
sMail_ids = cell.Offset(1, 0).Value
Else
sMail_ids = sMail_ids & vbCrLf & ";" & cell.Offset(1, 0).Value
End If
Next cell
Set myDataRng = Nothing ' Clear the range.
On Error Resume Next
With OutMail
.To = sMail_ids
.CC = ""
.BCC = ""
.Subject = "Weekindeling week " & Range("K1")
.Attachments.Add FileFullPath
.Display
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
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Place Cell Value in Subject Line of Mail

I generate an email in Microsoft Outlook from a ClickButton (ActiveX Controls) in Excel with code I found online.
How do I place a specific cell's value into the subject line (Cell M3 in my case)?
A number of codes I've found use "olMailItem", which my computer/network is having issues with due to the registry being corrupted; attempting to have that corrected but it may take some time.
How would I perform this function without using "olMailItem"?
I was able to find the answer after additional trial and error; it has an arrow pointing to it below
Sub Mail()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = "ron#debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line" & Range("A1").Value '<-- addition
.Body = "Hi there"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Mailing Multiple Sheets and a Specific Range Within One Sheet

I am trying to write a macro that will email all of Sheet 1 and Range("A7:P20") from Sheet 3. I copied the following code below, which works for sending entire sheets, but I am unsure how to adjust it so I only send the aforementioned range from Sheet 3 on a distinct sheet in addition to all of Sheet 1.
Sub Mail_Sheets_Array()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim TheActiveWindow As Window
Dim TempWindow As Window
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the sheets to a new workbook
'We add a temporary Window to avoid the Copy problem
'if there is a List or Table in one of the sheets and
'if the sheets are grouped
With Sourcewb
Set TheActiveWindow = ActiveWindow
Set TempWindow = .NewWindow
.Sheets(Array("Sheet1", "Sheet3")).Copy
End With
'Close temporary Window
TempWindow.Close
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
' 'Change all cells in the worksheets to values if you want
' For Each sh In Destwb.Worksheets
' sh.Select
' With sh.UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
' Destwb.Worksheets(1).Select
' Next sh
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = "ron#debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
You can add this code after Set Destwb = ActiveWorkbook.
Dim LastRowDest as Long
Dim LastColDest as Long
Destwb.sheets("sheet3").Select
LastRowDest = Destwb.sheets("sheet3").cells(rows.count,1).end(xlup).row
LastColDest = Destwb.sheets("sheet3").cells(1,columns.count).end(xltoleft).column
sheets("sheet3").Rows("21:" & LastRowDest + 1).Delete
sheets("sheet3").Rows("1:6").Delete
sheets("sheet3").columns("17:& LastColDest + 1).Delete
Hope this help.

How to save/overwrite the newly created copy of excel workbook with an appended name to a new partition

I have been working on a small automation project where I can send my workbook to a friend by saving it on a server and also by sending emails(now the server part is not important and I will work on it later).
Now I have been able to create a new file and copy all the contents. What I have done is copy all the sheets and save it in a new folder in the same directory. What I really want to do is create a new directory in a different partition say D:\Excel and save it in there with each of my friends having their own file names. And I also want to append the current date to the filename of the new workbook that is created and if a filename with date already exists for the particular friend, I want the new file to overwrite the existing file.
I have for this project already automated the sending of emails and the only problem there has been that I have not been able to send the email at a preset time.Whenever I click on send email,it goes automatically rather than the set time. Can anyone show me the right way to automate these things?
Private Sub Create_Click()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim dUMMY1 As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String
Dim dt As String, wbNam As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'Copy every sheet from the workbook with this macro
Set dUMMY1 = ThisWorkbook
'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = dUMMY1.Path & "\" & dUMMY1.Name & " " & DateString
MkDir FolderName
'Copy every visible sheet to a new workbook
For Each sh In dUMMY1.Worksheets
'If the sheet is visible then copy it to a new workbook
If sh.Visible = -1 Then
sh.Copy
'Set Destwb to the new workbook
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
If dUMMY1.Name = .Name Then
MsgBox "Your answer is NO in the security dialog"
GoTo GoToNextSheet
Else
Select Case dUMMY1.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
'Change all cells in the worksheet to values if you want
If Destwb.Sheets(1).ProtectContents = False Then
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If
'Save the new workbook and close it
With Destwb
.SaveAs FolderName _
& "\" & Destwb.Sheets(1).Name & FileExtStr, _
FileFormat:=FileFormatNum
.Close False
End With
End If
GoToNextSheet:
Next sh
MsgBox "You can find the files in " & FolderName
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Private Sub Send_Click()
Dim OutApp As Object
Dim OutMail As Object
Application.OnTime TimeValue("15:45:00"), "Auto_Update"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "abc#def.com"
.CC = ""
.BCC = ""
.Subject = "Testing "
.Body = ""
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Here is the file that I have been working on:
https://drive.google.com/open?id=0B7uN4B3mxUlZUjV6VnpLdUpQeEU

Delete All VBA code on the sheet before sending it via e-mail

I have this code that extracts only the active sheet and send it to specific email.
I have a 6 CommandButtons on that sheet which are attached to some codes.
So I need to implement some code in this(sending)code to delete all CB-s and all code in it, before sendin it. It would shrink sending file a lot.
Private Sub CommandButton5_Click()
'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim x As Integer
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Pregled " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
ActiveSheet.Shapes("CommandButton1").Delete 'this only deletes the CB-s
ActiveSheet.Shapes("CommandButton2").Delete
ActiveSheet.Shapes("CommandButton3").Delete
ActiveSheet.Shapes("CommandButton4").Delete
ActiveSheet.Shapes("CommandButton5").Delete
ActiveSheet.Shapes("CommandButton6").Delete
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "exemple#email.ba"
.CC = ""
.BCC = ""
.Subject = "Izvještaj za kutije"
.Body = "Izvještaj u prilogu! LP."
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Save your file (using a macro if you wish so) as .xlsx file instead of .xlsm .
Say you want to save Sheet1, Sheet2:
Sub SaveAsXSLX()
Worksheets(Array("Sheet1", "Sheet2")).Copy
ActiveWorkbook.SaveAs fileName:="NewFileName.xlsx"
end sub
This method shall prevent alert message popping (error message like "can not save this format to non macro format).