Run-time error '1004': Method 'Sheet' of object '_Global' failed

[blens1]

I have the following error mentioned in the title and the first time I run this VBA it works but the second time it always errors out. When I press the debug button it occurs on the following line:


Set rng = Sheets("qry_LastWeekApptTotal").Range("A1:B4").Spe cialCells(xlCellTypeVisible)



Private Sub cmd_MondayReport_Click()


Dim LastWeekApptTotal As String
LastWeekApptTotal = "\\L01...\LastWeekApptTotal" & Format(Date, "mm-dd-yyyy") & ".xlsx"


'Get That Data
DoCmd.SetWarnings (WarningsOff)
DoCmd.OpenQuery "qry_Caleb_Appointments", acViewNormal, acEdit
DoCmd.OpenQuery "qry_LastWeekApptTotal", acViewNormal, acEdit
DoCmd.SetWarnings (WarningsOn)


'Export to Excel
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_LastWeekApptTotal", LastWeekApptTotal, True


'close queries
DoCmd.Close acQuery, "qry_Caleb_Appointments"
DoCmd.Close acQuery, "qry_LastWeekApptTotal"


'Let's edit!
Dim objActiveWkb As Object, appExcel As Object


Set appExcel = CreateObject("Excel.Application")
appExcel.Visible = True
appExcel.Application.Workbooks.Open LastWeekApptTotal
Set objActiveWkb = appExcel.Application.ActiveWorkbook
appExcel.DisplayAlerts = False


With objActiveWkb
.Worksheets(1).Range("A4").FormulaR1C1 = "TOTAL"
.Worksheets(1).Range("B4").FormulaR1C1 = "=SUM(R[-2]C:R[-1]C)"
.Worksheets(1).Cells.EntireColumn.AutoFit
.Worksheets(1).Range("A1:B4").Borders(xlInsideVert ical).LineStyle = xlContinuous
.Worksheets(1).Range("A1:B4").Borders(xlInsideVert ical).ColorIndex = xlAutomatic
.Worksheets(1).Range("A1:B4").Borders(xlInsideVert ical).TintAndShade = 0
.Worksheets(1).Range("A1:B4").Borders(xlInsideVert ical).Weight = xlThin
.Worksheets(1).Range("A1:B4").Borders(xlInsideHori zontal).LineStyle = xlContinuous
.Worksheets(1).Range("A1:B4").Borders(xlInsideHori zontal).ColorIndex = xlAutomatic
.Worksheets(1).Range("A1:B4").Borders(xlInsideHori zontal).TintAndShade = 0
.Worksheets(1).Range("A1:B4").Borders(xlInsideHori zontal).Weight = xlThin
.Worksheets(1).Range("A1:B1").Font.Bold = True
.Worksheets(1).Range("A4:B4").Font.Bold = True


End With


'Draft email
Dim Email_Subject, Email_Send_From, Email_Send_To, _
Email_Cc, Email_Bcc, Email_Body As String
Dim Mail_Object, Mail_Single As Variant
Dim oOutlook As Outlook.Application
Dim oEmailItem As Outlook.MailItem
Dim dbs As DAO.Database
Dim fld As Field
Dim rng As Range
Dim emailaddress As String
Dim signature As String
Set oOutlook = Outlook.Application
Set oEmailItem = oOutlook.CreateItem(olMailItem)
subjstartdate = Format(Now - 8, "mm/dd/yyyy")
subjenddate = Format(Now - 2, "mm/dd/yyyy")


Email_Subject = " Appointment Totals " & subjstartdate & " - " & subjenddate
Email_Send_To = "britton.lense@publix.com"


Set dbs = CurrentDb
oEmailItem.Display
Set oemialitem = Outlook.CreateItem(0)
Set oOutlook = CreateObject("Outlook.Application")
Set rng = Sheets("qry_LastWeekApptTotal").Range("A1:B4").Spe cialCells(xlCellTypeVisible)
rng.Copy


With oEmailItem
.BodyFormat = olFormatHTML
.HTMLBody = RangetoHTML(rng) & "<br>" & signature
.Subject = Email_Subject
signature = oEmailItem.Body


End With


With oEmailItem
.To = Email_Send_To
.CC = Email_Cc
'.BCC = EmailAddr
.Display
'.Send


'Close Excel file
appExcel.Quit
Set objActiveWkb = Nothing


'Delete temp Excel file
Kill LastWeekApptTotal


End With


End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook


TempFile = Environ$("temp") & "" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"


'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
'Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0

End With


'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
FileName:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)

End With


'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center xublishsource=", _
"align=left xublishsource=")


'Close TempWB
TempWB.Close savechanges:=False


'Delete the htm file we used in this function
Kill TempFile


Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing


End Function

[ranman256]

when it stops there, check on the items to see if they are valid in Immediate window.

Is Sheets("qry_LastWeekApptTotal") still open?

is the Range still valid?
etc.

[blens1]

Yes to both above. The range is not copying over to the email that is already open.