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.
Related
This Sub should save an openwork book to a share-point site and name it for the user.
I know Object required is either from misspelling or from referencing an object that doesn't exist. I can't see any spelling mistakes with the below and I think I've declared the four variables being used to build the .SaveAs line.
What am I missing?
This is the line that's throwing up the error:
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
Full Save File Code:
Sub Save_To_Sharepoint()
Const FileExtStr As String = ".xlsm"
Const FileFormatNum As Long = 52
Dim TempFilePath As String
Dim TempFileName As String
TempFilePath = ("\\sharepoint\goes\here") & "\"
TempFileName = Range("A1").Text
'Build .SaveAs file Name based on variables established previously
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
End With
'Display successful submission message
MsgBox ("Thank you, your assessment has been successfully submitted.")
End Sub
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
I'm using VBA code from Ron de Bruin that sends every sheet with an email address to the address in a specified cell. It's meant to send the sheet as an attachment.
I want to get data from multiple cells, to put in the body of the email.
I commented out the parts that send the attachment and sent an email that contained data from one cell in the body of the email.
I cannot get data from multiple cells. The email arrives blank.
Sub Mail_Every_Worksheet()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
TempFilePath = Environ$("temp") & "\"
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
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
For Each sh In ThisWorkbook.Worksheets
If sh.Range("B1").Value Like "?*#?*.?*" Then
sh.Copy
Set wb = ActiveWorkbook
TempFileName = "Sheet " & sh.Name & " of " _
& ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutMail = OutApp.CreateItem(0)
With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = sh.Range("B1").Value
.CC = ""
.BCC = ""
.Subject = "Monthly Shirt Sales"
Dim cell As Range
Dim strbody As String
For Each cell In
ThisWorkbook.Sheets("Sheet1").Range("A4:A36")
strbody = strbody & cell.Value & vbNewLine
Next
'.Attachments.Add wb.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
Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If
Next sh
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
It works to send the data from one cell when I replace
Dim cell As Range
Dim strbody As String
For Each cell In ThisWorkbook.Sheets("Sheet1").Range("A4:A36")
strbody = strbody & cell.Value & vbNewLine
Next
with this:
.Body = sh.Range("A4").Value
so I thought that using this would work:
.Body = sh.Range("A4:B36").Value
but it also does not get data and sends a blank email.
How do I get data from multiple cells?
You need to loop through the range and combine the values in the range like in the following example;
Dim strbody As String
For Each cell In sh.Range("A1:B2")
strbody = strbody & cell.Value & vbNewLine
Next cell
Then include the strbody in you outlook with statement
With OutMail
.To = sh.Range("B1").Value
.CC = ""
.BCC = ""
.Subject = "Monthly Shirt Sales"
.Body = strbody
.send 'or use .Display
End With
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.
The first part of the code will not create the email ever since I added the strBody line and all.
I got the code from Ron de Bruin's site and added some things to it to adjust it for my needs.
Sub Send_Row()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2013
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim rng As Range
Dim Ash As Worksheet
Dim StrBody As String
Set Ash = ActiveSheet
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
StrBody = "Hello " & cel.Offset(, -1) & "<br>" & "<br>" & _
"We regret to inform you that there was an issue with the January interface file and your elections were not" & "<br>" & _
"processed correctly. In order to rectify this situation, we will issue new logs " & "<br>" & _
"you will not experience a big hit to time:" & "<br>" & "<br>" & _
"Please Check Proposed Adjustment Schedule below" & "<br>" & _
"Please contact ." & "<br>" & "<br>" & _
"Again, our sincere apologies for the mishaps with the interface file and any inconvenience this may have caused you." & "<br><br><br>"
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
For Each cell In Ash.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" _
And LCase(cell.Offset(0, 1).Value) = "yes" Then
'Change the filter range and filter Field if needed
'It will filter on Column B now (mail addresses)
Ash.Range("A1:J200").AutoFilter Field:=2, Criteria1:=cell.Value
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cel.Offset(0, -1).Value
.Subject = "Benefits Deductions"
.HTMLBody = StrBody & RangetoHTML(rng)
.Display 'Or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Ash.AutoFilterMode = False
End If
Next cell
cleanup:
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
On the first line of the StrBody = ..., you use a variable named cel, which seems to be undefined, this is probably what is throwing your program off.