I have a 120+ sheet workbook, the front page of which has a nice function to extract a specified sheet, saving it as a new book with a bunch of details. Which all works fine. Trying to add a new function though. On the extracted sheet, I've added a button and created a macro that will e-mail the finished article. The problem is, the location reference for the macro keeps defaulting back to the original book source, rather than the sheet itself (its all .XLSM files). The macro itself is on each sheet, but I can't find a way of fixing the reference for the macro to the sheet proper. And my google-fu has failed me. Any input or words of wisdom would be greatly appreciated!
OK, here's the mailer macro:
Sub Mail_FinishedSheet_Array()
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim OutApp As Object
Dim OutMail As Object
Dim SigString As String
Dim Signature As String
Dim StrBody As String
Set wb1 = ActiveWorkbook
If Val(Application.Version) >= 12 Then
If wb1.FileFormat = 51 And wb1.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file. There will" & vbNewLine & _
"be no VBA code in the file you send. Save the" & vbNewLine & _
"file as a macro-enabled (. Xlsm) and then retry the macro.", vbInformation
Exit Sub
End If
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Signature details with path
SigString = Environ("appdata") & _
"\Microsoft\Signatures\Zonal2014HO.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
' Make a copy of the file.
' If you want to change the file name then change only TempFileName variable.
TempFilePath = Environ$("temp") & "\"
TempFileName = wb1.Name & " " & Format(Now, "dd-mmm-yy hh-mm")
FileExtStr = "." & LCase(Right(wb1.Name, _
Len(wb1.Name) - InStrRev(wb1.Name, ".", , 1)))
wb1.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Set wb2 = Workbooks.Open(TempFilePath & TempFileName & FileExtStr)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
'Body contents for HTML format e-mail
StrBody = "<BODY style=font-size:11pt;font-family:Calibri>Hi," _
& "<p>Please find a completed checksheet attached for a PC Rebuild." _
& "<p>Regards, " _
& "<p></BODY>"
' Change the mail address and subject in the macro before you run this procedure.
With OutMail
.To = "Eng_Tech_support#zonal.co.uk"
.CC = "rob.brown#zonal.co.uk"
.BCC = ""
.Subject = "Completed PC Rebuild Checksheet " & Format(Now, "dd-mmm-yy")
.HTMLbody = StrBody & Signature
.Attachments.Add wb2.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Display
End With
On Error GoTo 0
wb2.Close SaveChanges:=False
' Delete the file.
' Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
And here's the extraction macro from the main page that seperates the desires sheet from the book and saves it as a new file:
Sub Full_Extract()
Dim wbkOriginal As Workbook
Set wbkOriginal = ActiveWorkbook
'sets site and engineer details into the estate page that is being extracted
Worksheets(Sheet1.CmbSheet.Value).Range("B3").Value = Worksheets("front page").Range("E6")
Worksheets(Sheet1.CmbSheet.Value).Range("D3").Value = Worksheets("front page").Range("N6")
Worksheets(Sheet1.CmbSheet.Value).Range("F3").Value = Worksheets("front page").Range("K6")
Worksheets(Sheet1.CmbSheet.Value).Range("B4").Value = Worksheets("front page").Range("F8")
Worksheets(Sheet1.CmbSheet.Value).Range("D4").Value = Worksheets("front page").Range("K8")
' copies sheet name from combo box into new document, saves it with site name and current date
' into C:\Temp\ folder for ease of access
With ActiveWorkbook.Sheets(Array((Sheet1.CmbSheet.Value), "Z-MISC"))
.Copy
ActiveWorkbook.SaveAs _
"C:\temp\" _
& ActiveWorkbook.Sheets(Sheet1.CmbSheet.Value).Cells(3, 2).Text _
& " " _
& Format(Now(), "DD-MM-YY") _
& ".xlsm", _
xlOpenXMLWorkbookMacroEnabled, , , , False
End With
'code to close the original workbook to prevent accidental changes etc
Application.DisplayAlerts = False
wbkOriginal.Close
Application.DisplayAlerts = True
End Sub
use an ActiveX button
which requires its associated code to be in the worksheet it resides in and that after that .Copy and ActiveWorkbook.SaveAs ... statements will point to the worksheet in newly created workbook
Mail_FinishedSheet_Array() Sub must also be in the new workbook if you want to make it independent from "Checkbook.xlsm". In this case that Sub must reside in one of the two worksheets (Sheet1.CmbSheet.Value or "Z-MISC") being copied in the new workbook
user3598756 nailed it. Using an ActiveX button and then assigning the macro to it directly (right click, view code) has worked perfectly.
Related
I am going to copy a active worksheet before send it out thought outlook, but it gave me a
"Run-time error '1004': We couldn't copy this sheet".
I have try few commands in below to copy the sheet just don't work:
ThisWorkSheet.Copy ' fist method
Worksheets("Confirm").Activate
ActiveSheet.Copy ' Second mehod
ActiveWorkbook.Sheets("Confirm").Copy ' Third method
All this came out error and debug is navigate to online of above code.
Sub Mail_ActiveSheet()
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 ' when debug this code come out error
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
FileExtStr = ".xlsm": FileFormatNum = 52
End If
End With
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = Range("F4").Value
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 = Range("B12").Value
.CC = ""
.BCC = ""
.Subject = "Order From " & Range("E8").Value
.HTMLBody = "<font face=""calibri"" style=""font-size:11pt;"">Dear Collegue, " & "<br><br>" & _
"Please kindly find the attached new order for " & Range("E8").Value & " above." & _
"<br><br>" & "Regards <br><br>" & Range("F6").Value & "<br><br>" & _
"Shop : " & Range("E8").Value & "<br>" & _
Range("E9").Value & "<br>" & _
Range("E10").Value & "<br>" & _
Range("E11").Value & "<br>" & .HTMLBody & "</font>"
.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
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Mail has been sent!"
Set OutApp = Nothing
'Set OutMail = Nothing End Sub
Please helps, thank you
The differences between .xlsx and .xls extensiond could be the cause.
.xlsx files can contain 1 048 576 rows in contrast to .xls, which can contain only 65 536 rows on a sheet.
So VBA tried to copy whole sheet with 1 048 576 to .xls workbook that can handle only 65 536 rows and you get an error.
As a decision you can copy concrete range A1:A65536 from .xlsx book to .xls.
I just encountered the same error message. It seems to be rare, as I couldn't find any other mention of it on the web.
The error occurred on a PC of one of my clients, who uses a VBA add-in I developed for him. Since he's in another country I couldn't investigate directly. I suggested he restart his PC (full restart, not just shut down and start up) and that seems to have fixed it. So apparently it was just a temporary glitch in Excel.
I got this error, and Richard noted, it is rare. As such, I wanted to share my fix for the issue.
One of the cases that makes this issue appear is if you try to copy a hidden sheet in Excel. To copy it, you need to unhide it first.
I have a code which I generated for the purpose of sending Outlook emails to clients who are overdue on invoice payments.
Currently, the code pulls data from cells in a workbook - "WB 1" - which I have manually input for each of our invoices into an email.
It then adds an email signature using SendKeys (I know this function is not favorable but I had troubles with other workarounds).
The code finally waits 5 seconds (to avoid any lag affecting the SendKeys) and repeats for as many invoices as selected in "WB 1".
What I would like to do is be able to incorporate within the code the ability to take the invoice number from "WB 1" and search the same value in our invoice log workbook - "WB 2".
I would like to then copy values from approximately 5 specific columns within that invoice number's row into "WB 1", which would mean I wouldn't have to manually transfer these values over for each and every invoice we send, benefiting efficiency of the process.
I have tried using the Find function but unfortunately with my limited knowledge in coding and a self taught beginner I am experiencing some problems.
Please let me know if I've made my explanation convoluted and I will be happy to discuss further.
Thank you for your time.
Sub DunningEmailv2()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "C").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.SentOnBehalfOfName = "xxx#xxx.xxx"
.Importance = olImportanceHigh
.To = cell.Value
.Subject = "Overdue Invoice Reminder from xxx"
.Body = "Dear " & Cells(cell.Row, "A").Value & "," _
& vbNewLine & vbNewLine & _
Cells(cell.Row, "D").Value & " have an outstanding invoice numbered (" & Cells(cell.Row, "E").Value & ")" & ", amounting to $" & Cells(cell.Row, "G").Value & "." _
& vbNewLine & vbNewLine & _
"This invoice is now " & Cells(cell.Row, "H").Value & " days overdue which has become a concern for us." _
& vbNewLine & vbNewLine & _
"Please provide confirmation as to when payment will be made." _
& vbNewLine & vbNewLine & _
"If you have any questions please feel free to ask." _
& vbNewLine & vbNewLine & _
"Kind regards," _
'.Attachments.Add ("C:\test.txt")
.Save
.Display
Dim currenttime As Date
currenttime = Now
Do Until currenttime + TimeValue("00:00:05") <= Now
Loop
SendKeys "^+{End}", True
SendKeys "{End}", True
SendKeys "%nas~", True
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
You can adapt this example from here
Sub CopyOpenItems()
'
' CopyOpenItems Macro
' Copy open items to sheet.
'
' Keyboard Shortcut: Ctrl+Shift+O
'
Dim wbTarget As Workbook 'workbook where the data is to be pasted
Dim wbThis As Workbook 'workbook from where the data is to be copied
Dim strName As String 'name of the source sheet/ target workbook
'set to the current active workbook (the source book)
Set wbThis = ActiveWorkbook
'get the active sheetname of the book
strName = ActiveSheet.Name
'open a workbook that has same name as the sheet name
Set wbTarget = Workbooks.Open("C:\filepath\" & strName & ".xlsx")
'select cell A1 on the target book
wbTarget.Range("A1").Select
'clear existing values form target book
wbTarget.Range("A1:M51").ClearContents
'activate the source book
wbThis.Activate
'clear any thing on clipboard to maximize available memory
Application.CutCopyMode = False
'copy the range from source book
wbThis.Range("A12:M62").Copy
'paste the data on the target book
wbTarget.Range("A1").PasteSpecial
'clear any thing on clipboard to maximize available memory
Application.CutCopyMode = False
'save the target book
wbTarget.Save
'close the workbook
wbTarget.Close
'activate the source book again
wbThis.Activate
'clear memory
Set wbTarget = Nothing
Set wbThis = Nothing
End Sub
My aim is to be able to click a button and for my Excel sheet to PDF a range of my spreadsheet and to email this to an email address which is in one of the cells in the sheet. For starters, I have the code which can turn a range of cells into a PDF file and allows me to save it:
Option Explicit
Sub savePDF()
Dim wSheet As Worksheet
Dim vFile As Variant
Dim sFile As String
Set wSheet = ActiveSheet
sFile = Replace(Replace(Range("D11"), " ", ""), ".", "_") _
& "_" _
& Range("H11") _
& ".pdf"
sFile = ThisWorkbook.Path & "\" & sFile
With Excel.Application.FileDialog(msoFileDialogSaveAs)
Dim i As Integer
For i = 1 To .Filters.Count
If InStr(.Filters(i).Extensions, "pdf") <> 0 Then Exit For
Next i
.FilterIndex = i
.InitialFileName = sFile
.Show
If .SelectedItems.Count > 0 Then vFile = .SelectedItems.Item(.SelectedItems.Count)
End With
If vFile <> "False" Then
wSheet.Range("A1:BF47").ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=vFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End If
End Sub
Can anybody manipulate this code (attached to a button) so it will email an email address, which is in a particular cell, when the button is clicked and as an added bonus, have the subject of the email work from a cell in the spreadsheet too?
I have a solution which is below. After I set my print area by going into page payout and then set print area, I successfully managed to email the excel sheet as a PDF file:
Sub savePDFandEmail()
Dim strPath As String, strFName As String
Dim OutApp As Object, OutMail As Object
strPath = Environ$("temp") & "\" trailing "\"
strFName = ActiveWorkbook.Name
strFName = Left(strFName, InStrRev(strFName, ".") - 1) & "_" & ActiveSheet.Name & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
strPath & strFName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = Range("CB4")
.CC = Range("CB6")
.BCC = ""
.Subject = Range("CB8")
.Body = Range("BW11") & vbCr
.Attachments.Add strPath & strFName
'.Display 'Uncomment Display and comment .send to bring up an email window before sending
.Send 'Keep this the same if you want to send the email address out on click of the button
End With
Kill strPath & strFName
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I also needed to put a little emailing tool into my sheet too which looks like this:
Clicking the button will now send the email with the PDF file attached.
I made the code (as shown below) which send one PDF by email correctly, but I need to send one more PDF.
Dim varFindThis As Variant
Dim rngLookIn As Range
varFindThis = Worksheets("Suivi").Range("B1")
Set rngLookIn = Worksheets("Suivi").Range("A:A")
If Not rngLookIn.Find(varFindThis, LookIn:=xlValues) Is Nothing Then
Dim f As String
f = Worksheets("Suivi").Range("B1").Value
'Since i didn't got that clear, here above you must create a code to declare "f" as whatever you want
Set c = Worksheets("Suivi").Range("A:A").Find(f)
Worksheets("Suivi").Range(c.Address).EntireRow.Delete
End If
'Do not forget to change the email ID
'before running this code
Dim OlApp As Object
Dim NewMail As Object
Dim TempFilePath As String
Dim TempFileName As String
Dim FileFullPath As String
' With Application
' .ScreenUpdating = False
' .EnableEvents = False
' End With
Application.DisplayFullScreen = False
ThisWorkbook.Worksheets("PDF").Activate
Range("B1:BG46").Select
ActiveSheet.PageSetup.PrintArea = "$B$1:$BG$46"
' Temporary file path where pdf
' file will be saved before
' sending it in email by attaching it.
TempFilePath = Environ$("temp") & "\"
' Now append a date and time stamp
' in your pdf file name. Naming convention
' can be changed based on your requirement.
TempFileName = ActiveSheet.Name & "-" & Format(Now, "dd-mmm-20yy") & ".pdf"
'Complete path of the file where it is saved
FileFullPath = TempFilePath & TempFileName
'Now Export the Activesshet as PDF with the given File Name and path
On Error GoTo err
With ActiveSheet
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=FileFullPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With
'Now open a new mail
Set OlApp = CreateObject("Outlook.Application")
'Loop through the rows
For Each cell In ThisWorkbook.Sheets("Envoie").Columns("C").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*#*" Then
EmailAddr1 = EmailAddr1 & ";" & cell.Value
End If
Next
For Each cell In ThisWorkbook.Sheets("Envoie").Columns("G").Cells.SpecialCells(xlCellTypeVisible)
If cell.Value Like "*#*" Then
EmailAddr2 = EmailAddr2 & ";" & cell.Value
End If
Next
Subj = "N°Article" & ThisWorkbook.Sheets("CalculInfo").Range("A10")
Set NewMail = OlApp.CreateItem(0)
On Error Resume Next
With NewMail
.To = EmailAddr1
.CC = EmailAddr2
.BCC = "gaetan.affolter#he-arc.ch"
.Subject = Subj
.Body = "Bonjour, il vous reste 24 heures pour vérifier les données du PDF et de confirmer dans Octopus. Merci"
.Attachments.Add FileFullPath '--- full path of the pdf where it is saved
.Send 'or use .Display to show you the email before sending it.
End With
On Error GoTo 0
'Since mail has been sent with the attachment
'Now delete the pdf file from the temp folder
Kill FileFullPath
'set nothing to the objects created
Set NewMail = Nothing
Set OlApp = Nothing
'Now set the application properties back to true
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox ("Email a été envoyé")
Exit Sub
err:
MsgBox err.Description
Unload Me
The PrintArea I situated in the Worksheets("CalcGammeControle") and more precisely in "$G$2:$G$35"
How can I add it?
My workbook has 5 different sheets and I need to copy the five sheets and paste it into 5 different mails. Preferably as HTML.
The below written code only attaches the different sheets to outlook. I need the HTML below the body of the email. Please note that my range in the sheets varies from workbook to workbook but the sheet names remain the same.
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level
'BrowseForFolder was a code originally written by Ron De Bruin, I love this function!
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
Sub SaveWorksheets()
'saves each worksheet as a separate file in a specific folder.
Dim ThisFolder As String
Dim NameOfFile As String
Dim Period As String
Dim RecipName As String
ThisFolder = BrowseForFolder()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim wsName As String
For Each ws In ActiveWorkbook.Worksheets
wsName = ws.Name
If wsName <> "Data" Then
Period = ws.Cells(4, 1).Value 'put the row and column numbers of the report date here.
RecipName = ws.Cells(1, 29).Value 'put the row and column numbers of the email address here
NameOfFile = ThisFolder & "\" & "Termination Report " & wsName & " " & Period & ".xlsx"
ws.Select
ws.Copy
ActiveWorkbook.SaveAs Filename:= _
NameOfFile, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
Call EmailWorkbooks(RecipName, NameOfFile)
End If
Next ws
End Sub
Sub EmailWorkbooks(RecipName, NameOfFile)
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.createItem(0)
Msg = "Attached is the xyz report for your review. Please let me know if you have any questions" & vbCrLf & vbCrLf _
& "Thanks," & vbCrLf & vbCrLf _
& "Your Name Here" & vbCrLf _
& "Your Title" & vbCrLf _
& "Your contact info"
Subj = "XYZ Report" & " " & Period
On Error Resume Next
With OutMail
.To = RecipName
'.CC =
.Subject = Subj
.Body = Msg
.Attachments.Add (NameOfFile)
.Save
End With
On Error GoTo 0
End Sub
U can use Add method of PublishObjects collection, short example:
Sub InsertSheetContent()
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
Set scriptingObject = CreateObject("Scripting.FileSystemObject")
Set outlookApplication = CreateObject("Outlook.Application")
For Each oneSheet In ThisWorkbook.Worksheets
htmlFile = ThisWorkbook.Path & "\" & ThisWorkbook.Name & "_" & oneSheet.Name & ".html"
Set onePublishObject = ThisWorkbook.PublishObjects.Add(SourceType:=xlSourceRange, _
Filename:=htmlFile, _
Sheet:=oneSheet.Name, _
Source:=oneSheet.UsedRange.Address, _
HtmlType:=xlHtmlStatic, _
DivID:=oneSheet.Name)
onePublishObject.Publish Create:=True
Set textStream = scriptingObject.OpenTextFile(htmlFile)
htmlBody = textStream.ReadAll
Set outlookMail = outlookApplication.CreateItem(0)
With outlookMail
.htmlBody = htmlBody
.Display
End With
Next oneSheet
End Sub