Issue with CopyFromRecordset run-time error 80010100 1

[mathguy1433]

Hello,

I am building some code to send emails with attachments to clients, so I am copying recordsets to excel sheets and then sending the excel file to them. Basically every record in the recordset correlates to an attached email.

Essentially I continue to get this error, "Run-time error '-2147417856 (80010100)' Method 'CopyFromRecordset' of object 'Range' failed" when trying to copy from a recordset to my excel file range. The bizarre thing is that if I click debug and continue running the code, the data actually copies correctly and it does exactly what needs to happen. But if I add an error line on error resume next, the copyfromrecordset method does absolutely nothing and my files send out as blank. I could really use any help anyone could suggest.
I should quickly add that the first 5 or so records of the task work perfectly fine everytime then it starts to error out randomly on the copyfromrecordset lines.

sample code: (I removed the non relevant Dim's as well as most of the code that occurs after the copyfromrecordset
Option Compare Database
Public Function AllReportsEmailTest()
Dim OutputFolder As String
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
Dim wb1, wb2, wb3, wb4 As Excel.Workbook
Dim ws As Excel.Worksheet
Dim ws1, ws2, ws3, ws4 As Excel.Worksheet
Dim MyDB As DAO.Database
Dim RS As DAO.Recordset
Dim tsql, Csql, rsql As String
Dim SavedExcelSheet As String
Dim rsqry, rsqry1, rsqry2, rsqry3, rsqry4, rsqry5, rsqry6, rsqry7, rsqry8, rsqry9, rsqry10, rsqry11, rsqry12, rsqry13, rsqry14, rsqry15, rsqry16, rsqry17, rsqry18, rsqry19, rsqry20 As DAO.Recordset

ReportName = "qryReportCard"
sourcename = "S:\Old Report Cards\" & ReportName
OutputFolder = "S:\PDF File"
qry = "qryReportCard"
Set MyDB = CurrentDb
Set RS = MyDB.OpenRecordset(qry)
RS.MoveLast
RS.MoveFirst
Set objOutlook = CreateObject("Outlook.Application")

'r is used to match individual records with email attachment
r = 2
q = 0
Do While Not RS.EOF
If IsNull(DLookup("[Email Address]", qry, "[Email Address] = '" & RS![Email Address] & "'")) Then GoTo phase2
If IsNull(DLookup("[MemberID]", qry, "[MemberID] = '" & RS![MemberID] & "'")) Then GoTo phase2

Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
TheAddress = RS![TestEmailAddress]

With objOutlookMsg
' Add the To recipients to the e-mail message.
Set objOutlookRecip = .Recipients.Add(TheAddress)
objOutlookRecip.Type = olTo
Set objOutlookRecip = .Recipients.Add("email")
objOutlookRecip.Type = olBCC
Set rsqry = MyDB.OpenRecordset("SELECT * From qryReportCard Where MemberID = '" & RS![MemberID] & "'", dbOpenDynaset)
Set rsqry1 = MyDB.OpenRecordset("SELECT * FROM qryGapReport Where MemberID = '" & RS![MemberID] & "'", dbOpenDynaset)
Set rsqry2 = MyDB.OpenRecordset("SELECT [Measure Name], [Measure Code], [Measure Description] FROM tblGapMetrics", dbOpenDynaset)
Set rsqry3 = MyDB.OpenRecordset("SELECT * FROM qryRiskReport Where MemberID = '" & RS![MemberID] & "'", dbOpenDynaset)
' ..... there are more (but you get the picture)

strnpi = RS![MemberID]
Set xlApp = CreateObject("Excel.Application")
xlApp.ScreenUpdating = False
Set wb = xlApp.Workbooks.Open(OutputFolder & "\" & SavedExcelSheet & ".xlsx")
wb.Worksheets("DataInput").Range("B2").CopyFromRecordset rsqry
with xlApp
[highlight yellow] wb.Worksheets("MemberRiskReport").Range("A2").CopyFromRecordset rsqry3[/highlight] (where error occurs)
wb.Worksheets("Service").Range("K7").CopyFromRecordset rsqry4
wb.Worksheets("GapReport").Range("A2").CopyFromRecordset rsqry1
wb.Worksheets("GapMetrics").Range("A2").CopyFromRecordset rsqry2
'...

wb.SaveAs (OutputFolder & "\" & SavedExcelSheet & " " & RS![MemberID] & ".xlsx")
wb.SaveAs ("S:\Provider Relations\NexUS\NexUS DB\NexUS Scorecard Backups\" & "NexUS Scorecards " & datetime1 & " " & RS![MemberID] & ".xlsx")
wb.Close

xlApp.Workbooks.Close
xlApp.Quit
xlApp.DisplayAlerts = True
xlApp.Visible = False
Set xlApp = Nothing
Set wb = Nothing
End With

If Not IsMissing(OutputFolder & "\" & SavedExcelSheet & " " & RS![MemberID] & ".xlsx") Then
Set objOutlookAttach = .Attachments.Add(OutputFolder & "\" & SavedExcelSheet & " " & RS![MemberID] & ".xlsx")
End If

Kill OutputFolder & "\" & SavedExcelSheet & " " & RS![MemberID] & ".xlsx"
MyDB.QueryDefs.Delete ("GraphGeneration")


' Resolve the name of each Recipient.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
End If
Next
.Send
'.Send .display to see them if you want to auto send it

End With


rsqry.Close
rsqry1.Close
rsqry2.Close
rsqry3.Close
phase2:

RS.MoveNext
r = r + 1

Loop

MyRS.Close
t = Nothing
v = Nothing
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End Function

 

[Andrzejek]

You do realize (or maybe not...) that this line:
[tt]
Dim rsqry, rsqry1, rsqry2, rsqry3, rsqry4, rsqry5, rsqry6, rsqry7, rsqry8, rsqry9, rsqry10, rsqry11, rsqry12, rsqry13, rsqry14, rsqry15, rsqry16, rsqry17, rsqry18, rsqry19, [blue]rsqry20 As DAO.Recordset[/blue]
[/tt]
Actually says:
[tt]
Dim rsqry [red]As Variant[/red], rsqry1 [red]As Variant[/red], rsqry2 [red]As Variant[/red], rsqry3 [red]As Variant[/red], rsqry4 [red]As Variant[/red], rsqry5 [red]As Variant[/red], rsqry6 [red]As Variant[/red], rsqry7 [red]As Variant[/red], rsqry8 [red]As Variant[/red], rsqry9 [red]As Variant[/red], rsqry10 [red]As Variant[/red], rsqry11 [red]As Variant[/red], rsqry12 [red]As Variant[/red], rsqry13 [red]As Variant[/red], rsqry14 [red]As Variant[/red], rsqry15 [red]As Variant[/red], rsqry16 [red]As Variant[/red], rsqry17 [red]As Variant[/red], rsqry18 [red]As Variant[/red], rsqry19 [red]As Variant[/red], [blue]rsqry20 As DAO.Recordset[/blue]
[/tt]
So, only rsqry20 is declared As DAO.Recordset, all others are Variants.
I would investigate this first


---- Andy

There is a great need for a sarcasm font.

 

[combo]

It seems that excel is not yet available when you copy the recordset add a pause before copying data (thread705-1788327).

For testing you could slightly modify the code:
[tt]Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
' xlApp.ScreenUpdating = False
Set wb = xlApp.Workbooks.Open(OutputFolder & "\" & SavedExcelSheet & ".xlsx")[/tt]

Before copying you may test if the workbook is avaliable:
[tt]MsgBox Not wb.Worksheets("DataInput").Range("B2") Is Nothing[/tt]

NB, after [tt]Dim wb1, wb2, wb3, wb4 As Excel.Workbook[/tt] only wb4 is declared as workbook, the rest are Variant.


combo

 

[SkipVought]

Holy macro, Batman!

First, get ONE query to work in your workbook/worksheet and then LOOP to get your 21 querytables.

Second, put your essential data for each QT in a table, (SQL, Worksheet Name, Range Reference). Then do an outer loop thru the table to get your 21 queries. Your code could be reduced significantly!

Third, your loop is designed to read thru the recordset object. HOWEVER, the CopyFromRecordset method, places the entire recordset at the specified range. Perhaps the recordset's EOF becomes TRUE when that operation is complete.

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]
"The most incomprehensible thing about the universe is that it is comprehensible" A. Einstein

 

[Andrzejek]

You should be getting other errors as well:
[tt]
MyRS.Close
[/tt]
MyRS is not declared, not in the sample you show.
I would guess you do not have [tt]Option Explicit[/tt] at the top of your code...



---- Andy

There is a great need for a sarcasm font.

 

[mathguy1433]

Thnaks Andrzejek I will look at that, I actually did not know that. I assumed that would be the case based on my knowledge of C++.... whoops
I will change that and see if it impacts it

 

[mathguy1433]

Yeah Skip I actually left out pretty much all of the code after the copyfromrecordset lines. its probably another 200 lines, but I do not know if looping would work as every paste location is unique.

Either way my copyfromrecordset lines are all where statements (specifically rsqry would always be 1 row) is there a better way to just copy one row from access to excel? The other recordset copies can be from null to around 100 rows.

 

[mathguy1433]

So the variable definitions did not seem to make an impact, im still getting the error, this time on line - wb.Worksheets("MemberRiskReport").Range("A2").CopyFromRecordset rsqry3, after about the 5th or 6th record is run correctly

 

[Andrzejek]

If you had an error on line:[tt]
wb.Worksheets("DataInput").Range("B2").CopyFromRecordset [blue]rsqry [/blue][/tt]
and you made some changes to your code, and now you error on line:
[tt] wb.Worksheets("MemberRiskReport").Range("A2").CopyFromRecordset [red]rsqry3[/red][/tt]
"after about the 5th or 6th record is run correctly " - that is different.

What error are you getting?


---- Andy

There is a great need for a sarcasm font.

 

[mathguy1433]

It is the exact same error code on that line. I put that in the original post that it would run just fine for the first 5 or 6 iterations of my RS loop.

So after further review and some error handling, it appears that the issue arises with the first copyfromrecordset method that is after the original rsqry copyfromrecordset line, seemingly no matter which query you are trying to copy and paste, but as I said before this occurs for like the 5th record in the RS recordset.

 

[Andrzejek]

It looks to me that you create and destroy [tt]xlApp[/tt] and [tt]wb[/tt] for every record in your RS. Why?
Can't you create those objects at the beginning just once, deal with them, and set them to Nothing at the end?

You may want to use combo's suggestion to check the state of your Excel objects when they error.


---- Andy

There is a great need for a sarcasm font.

 

[mathguy1433]

So the reason I create and destroy for every record is that every single record in RS sends an email out. Basically RS is a distinct list of clients that need to receive a performance review email. So I must create a new WB for each with only their data applicable (due to HIPPA compliance). I could potentially create xlApp once and destroy it at the end.

Also I just used Combo's suggestion and did the "msgbox wb not is nothing" and the code actually ran fine. What does that imply? should I add an if statement checking for this? and if so what does that look like? sorry for the simple question, I am not a programmer by trade I'm a data analyst so everything I know about code and vba is self taught.

 

[Andrzejek]

>the code actually ran fine. What does that imply?
It is (probably) what combo said:

excel is not yet available when you copy the recordset add a pause before copying data

The Message Box that you had gave your app a little pause to allow Excel to be created and ready for copying.

That's another reason to create Excel once at the beginning and destroy it (once) at the end.

---- Andy

There is a great need for a sarcasm font.

 

[mathguy1433]

Wow could it really be that simple? okay I will add a pause function after the xlApp.wb call

 

[mathguy1433]

Adding a time delay worked, apparently the computer was moving faster than the code could execute! Thank you guys so much for all of your help.

 

[Andrzejek]

The posts and replays here on TT help you, but others also look for solutions to the same or similar problems. So it would help others if you would elaborate a little more about what was the solution to your issue, because "It worked!" doesn't really help anybody. :-(

Also, it is customary here at TT to award a star by clicking on [blue]Great Post![/blue] link in helpful post. I would guess that would be combo's reply, right?

Welcome to Tek-Tips


---- Andy

There is a great need for a sarcasm font.

 

[mathguy1433]

I will update my post with the code that worked.

 

[combo]

[tt]xlApp.Quit[/tt] closes [tt]xlApp[/tt] excel instance you created, so the next two lines do nothing:
[tt]xlApp.DisplayAlerts = True
xlApp.Visible = False[/tt]

combo

 

[Andrzejek]

Also, your:

[pre]
With xlApp
....
End With[/pre]

doesn't do anything, there is no reference to this [tt]xlApp[/tt] anywhere (that I can see)


---- Andy

There is a great need for a sarcasm font.