Excel Paste special error in second loop in Microsoft Access

Hi,

Currently I'm trying to automate email sending code, the codes are working fine in microsoft excel. and now i want to enhance the code to be in microsoft access. so the idea is to send emails based on list of users emails in a table

all codes are working find in first loop, however it always resulting paste special error 1004 in second loop for line 177

.Cells(1).PasteSpecial xlPasteValues, , False, False


below are the full codes

Please help me on this

Option Compare Database
Dim XLApp2 As Excel.Application

Sub sendEmail()

'Open Database

Dim rs As DAO.Recordset
Set rs = CurrentDb.OpenRecordset("SELECT * FROM [3 list for sending report]")

Dim ExcelName As String
Dim filename As String


'Check to see if the recordset actually contains rows
If Not (rs.EOF And rs.BOF) Then
    rs.MoveFirst 'Unnecessary in this case, but still a good habit
    Do Until rs.EOF = True
        
    If rs!isSend = "Yes" Then
     'Get Report Source
      sReportName = rs![Report_Name]
        
     'Open Report Source
      ExcelName = Forms("frm_Demand_Generation").Controls("txt_main_file").Value & "\" & sReportName
      filename = GetFilenameFromPath(ExcelName)

      If IsFileOpen(ExcelName) = False Then
         Set XLApp2 = CreateObject("Excel.Application")
         XLApp2.Workbooks.Open ExcelName, True, False
         XLApp2.Visible = True
      Else
         Set XLApp2 = GetObject(ExcelName).Application
      End If
      
      'Send Update Begin
         XLApp2.ActiveWorkbook.Activate
         
         Dim rng As Excel.Range
         Dim rng2 As Excel.Range

         With XLApp2.Application
              .Calculation = False
              .EnableEvents = False
              .ScreenUpdating = True
         End With
    
         Set myOlApp = CreateObject("Outlook.Application")
         Set myitem = myOlApp.CreateItem(0)
         Set Safemail = CreateObject("Redemption.SafemailItem")

         EmailAddress = rs![Rep Email]
         CCEmailAddress = rs![FLM Email]

         MRName = rs![REP Name]
         XLApp2.Sheets("Genmed Business Tracker - v2").Activate
         XLApp2.ActiveSheet.Range("$B$3:$BJ$3").AutoFilter Field:=5, Criteria1:=rs![REP Name]
         XLApp2.[rangetoCopyV2].Select
    
         Set rng = Nothing

         'Only the visible cells in the selection
         Set rng = XLApp2.Selection.SpecialCells(xlCellTypeVisible)

         'You can also use a fixed range if you want
         'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
         If rng Is Nothing Then
            MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
            Exit Sub
          End If

          XLApp2.Sheets("PF and Coverage").Activate
          XLApp2.ActiveSheet.Range("$A$1:$V$1").AutoFilter Field:=5, Criteria1:=rs![REP Name]
          XLApp2.ActiveSheet.Range("$A$1:$V$1").AutoFilter Field:=22, Criteria1:="=NOT PF"   ', Operator:=xlOr, Criteria2:="=PF0"
          XLApp2.ActiveSheet.Range(XLApp2.ActiveSheet.Range("H1:S1"), XLApp2.ActiveSheet.Range("H1:S1").End(xlDown)).Select

          Set rng2 = Nothing

          'Only the visible cells in the selection
          Set rng2 = XLApp2.[pf_list] 'Selection.SpecialCells(xlCellTypeVisible)

          'You can also use a fixed range if you want
          'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
          If rng2 Is Nothing Then
             MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
             Exit Sub
          End If

          With myitem
               .To = EmailAddress
               .CC = CCEmailAddress
               Set Safemail.Item = myitem
               Safemail.Subject = "[For your follow up]: QTQ Progress update - " & MRName & " - " & Forms("frm_Demand_Generation").Controls("txtperiod").Value
 
    
               .HTMLBody = "<b>Dear " & MRName & "</b>" & _
                           "<br><br>Berikut ini progress update performance QTQ anda untuk bulan ini dengan tarikan data tanggal : " & 
                            Forms("frm_Demand_Generation").Controls("txtperiod").Value & _
                           "<br>" & _
                           RangetoHTML(rng) & _
                           "<br><br>" & _
                           "<br><br> berikut list dokter anda yang belum memenuhi KPI Product Frequency dibulan ini : " & _
                           "<br>" & _
                           RangetoHTML(rng2) & _
                           "<br>" & _
                           "</center><br>Catatan: " & _
                           "<br>1. Pastikan untuk selalu melakukan proses sinkronisasi setiap hari agar data QTQ dapat tercantum di progress update ini" & _
                           "<br>2. Anda dapat menjadikan list dokter yang belum PF untuk plan call anda" & _
                           "<br><br>Salam,<br>SFE Team"

           End With
           Safemail.Send
           Set Safemail = Nothing
           Set myOlApp = Nothing

           With XLApp2.Application
               .Calculation = True
               .EnableEvents = True
               .ScreenUpdating = True
           End With
           
        'Perform an edit
        rs.Edit
        rs!isSent = "Sent"
        rs.Update
        
        XLApp2.DisplayAlerts = False
        XLApp2.Quit
        Set XLApp2 = Nothing
        Set rng = Nothing
        Set rng2 = Nothing
    Else
     
        'Perform an edit
        rs.Edit
        rs!isSent = "Skipped"
        rs.Update
    End If
    
     'End of Update
      
     'Move to the next record. Don't ever forget to do this.
     rs.MoveNext
    Loop
Else
    MsgBox "There are no records in the recordset."
End If

MsgBox "Finished looping through records."

rs.Close 'Close the recordset
Set rs = Nothing 'Clean up
Set XLApp2 = Nothing

End Sub


Function RangetoHTML(rng As Excel.Range)

    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Excel.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)
    TempWB.Application.Visible = True

    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False            'it always error in this line at second loop
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        
        TempWB.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 x:publishsource=", _
                          "align=left x:publishsource=")

    '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

Select allOpen in new window

Thanks,
Fauzie