Excel Paste special error in second loop in Microsoft Access

Fauzie Bachri
Fauzie Bachri used Ask the Experts™
on
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
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Subodh Tiwari (Neeraj)Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015

Commented:
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

Author

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
Subodh Tiwari (Neeraj)Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015

Commented:
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.
Ensure you’re charging the right price for your IT

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!

Author

Commented:
Hi Neeraj.

already done that but still no idea


Regards,
Fauzie
Subodh Tiwari (Neeraj)Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015

Commented:
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?

Author

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
Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015
Commented:
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

Author

Commented:
Hi Neeraj,

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


Regards,
Fauzie
Subodh Tiwari (Neeraj)Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015

Commented:
Well, I am not sure why that's happening.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial