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

Open in new window


Thanks,
Fauzie
Fauzie BachriAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Try to use constants for the members of xlPasteType like you used at line#176 and see if that works for you.

With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial -4163
    .Cells(1).PasteSpecial -4122
    .Cells(1).Select
End With

Open in new window

0
Fauzie BachriAuthor Commented:
Hi Neeraj,

Thank you for your solution, its indeed remove the error. however the pastespecial result is not as expected

below is the result sample

Any idea on this..Thanks

This is pastespecial result with original code at first loop, but error at second loop at line 177

this is correct pastespecial at first loop with original code
This is pastespecial result after changing to your code at first loop

This is pastespecial result after changing to your code at first loop
This is pastespecial result after changing to your code at second loop onward

This is pastespecial result after changing to your code at second loop
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
I am not sure about that behavior. Insert some breakpoints in the code and try to step through the code by pressing F8 key, maybe that will give you an idea about how each line is behaving.
0
10 Tips to Protect Your Business from Ransomware

Did you know that ransomware is the most widespread, destructive malware in the world today? It accounts for 39% of all security breaches, with ransomware gangsters projected to make $11.5B in profits from online extortion by 2019.

Fauzie BachriAuthor Commented:
Hi Neeraj.

already done that but still no idea


Regards,
Fauzie
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
So if you insert breakpoints on the lines 176:178 after tweaking them and then debug the code, what do you notice? Does the code work as desired then?
0
Fauzie BachriAuthor Commented:
Hi Neeraj,

what i can observe is in the original code at first loop

line 176 will copy the source column structure only without any data on it. so it will result the same column widht or hidden column the same as the source

line 177 will copy value (also flattern all the formula) all the data but without conditional formatting

line 178 will copy all source format including conditional formatting

all 3 lines if doing properly liike above will have copy paste behaviour as expected

with using your code the behaviour is different

at first loop line 176-178 has the same result that is will copy paste value all the data and source format but not the column structure

at 2nd loop and above line 176-178 will result copy paste all the but without the source format and column structure


Regards,
Fauzie
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
That's strange because line176 was unchanged so why it would behave differently?
Try adding the TempWB first and then use rng.copy before each paste special line line below and see if that makes any difference.

'Copy the range and create a new workbook to past the data in
Set TempWB = Workbooks.Add(1)
TempWB.Application.Visible = True

With TempWB.Sheets(1)
    rng.Copy
    .Cells(1).PasteSpecial Paste:=8
    rng.Copy
    .Cells(1).PasteSpecial -4163            'it always error in this line at second loop
    rng.Copy
    .Cells(1).PasteSpecial -4122

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Fauzie BachriAuthor Commented:
Hi Neeraj,

adding rng.copy only work for 1st loop, 2nd loop above still has the same result as previous


Regards,
Fauzie
0
Subodh Tiwari (Neeraj)Excel & VBA ExpertCommented:
Well, I am not sure why that's happening.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Office

From novice to tech pro — start learning today.