Access Reference

B

bdavis6290

New member
Local time
Today, 18:10
Joined
Jun 2, 2014
Messages
9
:banghead::banghead::banghead::banghead::banghead:I wrote some code in Office 2010, when I upgraded to Office 2016 my code stop working when it is gets to the writting stage of the code. Instead of creating a new Excel and writing data, it keeps creating a blank Excel. This exact code works in Office 2010. I attached a picture with my reference from 2010 (left) and 2016 (right). Any help is greatly appreciated




​
Option Compare Database

Public Sub dbcodeexport(ByVal exportfile As String, ByVal exportdir As String)

On Error GoTo errorx

'Variables
Dim db As Database
Dim rs As DAO.Recordset
Set db = CurrentDb 'Open Database
Dim dbnum As String
Dim ename As String
Dim Pcode As String
Dim pname As String
Dim sqdone As String
Dim sqtest As Integer
Dim charge As Currency

'Excel Variables
Dim xlApp As Excel.Application
Dim wb As Workbook
Dim ws As Worksheet
Set xlApp = New Excel.Application 'Start The Excel Control


stsq:
Set rs = db.OpenRecordset("tblProviderAggFinal", dbOpenDynaset)
nextx:
If rs.EOF Then
GoTo endsq
End If

ename = rs.Fields("SpecialtyCode")
If Len(ename) > 2 Then
ename = Mid(ename, 1, 2)
End If

sqtest = InStr(sqdone, ename)
If sqtest > 0 Then
rs.MoveNext
GoTo nextx
Else
dbnum = ename
sqdone = sqdone & "<" & ename & ">"
End If

'Excel Renaming
Set rs = db.OpenRecordset("tblSpecialty", dbOpenDynaset)
startE:
If rs.EOF Then GoTo endE
ename = rs.Fields("Provider_Specialty_Code")
If ename = dbnum Then
ename = rs.Fields("Specialty")
GoTo endE
End If
rs.MoveNext
GoTo startE
endE:
ename = Replace(ename, ":", ",")
ename = Replace(ename, "/", ",")
ename = Replace(ename, "", ",")

'Copying Excel
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")

fs.CopyFile exportfile, exportdir & ename & " " & dbnum & ".xlsx"

'Excel Setup
Set wb = xlApp.Workbooks.Open(exportdir & ename & " " & dbnum & ".xlsx") 'Open The Excel File
On Error Resume Next

Set ws = wb.sheets(dbnum)
If ws Is Nothing Then GoTo endx

'Writing Stage
Set rs = db.OpenRecordset("SELECT * FROM tblProviderAggFinal ORDER BY Provider DESC", dbOpenDynaset)
start:

If rs.EOF = True Then
GoTo endx
End If

Pcode = rs.Fields("SpecialtyCode")
If Len(Pcode) > 2 Then
Pcode = Mid(Pcode, 1, 2)
End If

charge = rs.Fields("SumOfChargeAmt")
If Pcode = dbnum Then
If charge >= 150000 Then
pname = rs.Fields("Provider")
Dim pagename As String
If InStr(pname, ",") > 0 Then
pagename = Mid(pname, 1, InStr(pname, ",") + -1)
Else
pagename = Mid(pname, 1, InStr(pname, ";") + -1)
End If

ws.Copy wb.sheets(1)
wb.sheets(1).Name = pagename
Set ws = wb.Worksheets(1)
Dim testval As String

' testval = ""
' On Error Resume Next
' testval = ws.Range("a8").Value
' If InStr(testval, ",") > 0 Then
' ws.Range("a8").Value = pname
' GoTo edofset
' End If

testval = ""
On Error Resume Next
testval = ws.Range("a9").Value
If InStr(testval, ",") > 0 Then
ws.Range("a9").Value = pname
GoTo edofset
End If

testval = ""
On Error Resume Next
testval = ws.Range("a10").Value
If InStr(testval, ",") > 0 Then
ws.Range("a10").Value = pname
GoTo edofset
End If

testval = ""
On Error Resume Next
testval = ws.Range("a11").Value
If InStr(testval, ",") > 0 Then
ws.Range("a11").Value = pname
GoTo edofset
End If

testval = ""
On Error Resume Next
testval = ws.Range("a12").Value
If InStr(testval, ",") > 0 Then
ws.Range("a12").Value = pname
GoTo edofset
End If

'Test for ; between the provider last name and first name
testval = ""
On Error Resume Next
testval = ws.Range("a8").Value
If InStr(testval, ";") > 0 Then
ws.Range("a8").Value = pname
GoTo edofset
End If

testval = ""
On Error Resume Next
testval = ws.Range("a9").Value
If InStr(testval, ";") > 0 Then
ws.Range("a9").Value = pname
GoTo edofset
End If

testval = ""
On Error Resume Next
testval = ws.Range("a10").Value
If InStr(testval, ";") > 0 Then
ws.Range("a10").Value = pname
GoTo edofset
End If

testval = ""
On Error Resume Next
testval = ws.Range("a11").Value
If InStr(testval, ";") > 0 Then
ws.Range("a11").Value = pname
GoTo edofset
End If

testval = ""
On Error Resume Next
testval = ws.Range("a12").Value
If InStr(testval, ";") > 0 Then
ws.Range("a12").Value = pname
GoTo edofset
End If
edofset:


End If
End If

rs.MoveNext
GoTo start
endx:
xlApp.Application.DisplayAlerts = False
xlApp.Save
xlApp.Application.DisplayAlerts = False
xlApp.Application.Quit

GoTo stsq
errorx:
status = "Error please contact your admin"
endsq:

'Saving Stage
xlApp.Application.DisplayAlerts = False
xlApp.Application.Quit
End Sub
 

Attachments

  • 2017_05_22_17_22_32_Doc1_Word.jpg
    2017_05_22_17_22_32_Doc1_Word.jpg
    52.9 KB · Views: 179
Try changing the 4th reference to
'Microsoft Office 16.0 Access database engine object library'

If that doesn't fix it, suggest you repost enclosing your code in code tags
using the # tool in Advanced View

That will make it much easier to read & for someone to respond
 
I see some mixed-version library references. Usually when you have a new installation, you have .DLLs of related items keep their version number or all change the same. By "related items" I mean anything under the Office umbrella. But you have Access 16 and Excel 14, which doesn't seem right, and THEN to keep it curious, you have Access Database object at version 14 as well.

I'm wondering if something got confused by the mixed version numbering that I see. I'm not saying that's it, but it jumps out at me as suspicious.
 
Sorry for the confusion. The library references on the left are from my 2010 access database and the library references on the right is from my 2016 access database.
 
I don't have 'Microsoft Office 16.0 Access database engine object library' as an option in my list references for Access 2016. Can I download it from the net?
 
I'm reinstalling my Office 2016. My colleague had the same issue, and after she completely removed Office and preformed a clean install she was able to select 'Microsoft Office 16.0 Access database engine object library'. I will post a replay with the results after I finish the install.
 
You should be able to browse for it ...
However if that doesn't help, its usually enough to just do a repair rather than a reinstall
 
I reinstalled Office, however instead of Microsoft Office 14.0 Access database engine Object library it has 15.0, no 16.0 listed as an option. :banghead:

Code: 
Option Compare Database

Public Sub dbcodeexport(ByVal exportfile As String, ByVal exportdir As String)

On Error GoTo errorx

'Variables
Dim db As Database
Dim rs As DAO.Recordset
Set db = CurrentDb 'Open Database
Dim dbnum As String
Dim ename As String
Dim Pcode As String
Dim pname As String
Dim sqdone As String
Dim sqtest As Integer
Dim charge As Currency

'Excel Variables
Dim xlApp As Excel.Application
Dim wb As Workbook
Dim ws As Worksheet
Set xlApp = New Excel.Application 'Start The Excel Control


stsq:
Set rs = db.OpenRecordset("tblProviderAggFinal", dbOpenDynaset)
nextx:
If rs.EOF Then
    GoTo endsq
        End If

ename = rs.Fields("SpecialtyCode")
If Len(ename) > 2 Then
    ename = Mid(ename, 1, 2)
        End If

sqtest = InStr(sqdone, ename)
If sqtest > 0 Then
    rs.MoveNext
        GoTo nextx
            Else
                dbnum = ename
                    sqdone = sqdone & "<" & ename & ">"
                        End If

'Excel Renaming
Set rs = db.OpenRecordset("tblSpecialty", dbOpenDynaset)
startE:
If rs.EOF Then GoTo endE
    ename = rs.Fields("Provider_Specialty_Code")
        If ename = dbnum Then
            ename = rs.Fields("Specialty")
                GoTo endE
                    End If
rs.MoveNext
    GoTo startE
endE:
ename = Replace(ename, ":", ",")
    ename = Replace(ename, "/", ",")
        ename = Replace(ename, "\", ",")

'Copying Excel
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")

fs.CopyFile exportfile, exportdir & ename & " " & dbnum & ".xlsx"

'Excel Setup
Set wb = xlApp.Workbooks.Open(exportdir & ename & " " & dbnum & ".xlsx")  'Open The Excel File
On Error Resume Next

Set ws = wb.sheets(dbnum)
If ws Is Nothing Then GoTo endx

'Writing Stage
Set rs = db.OpenRecordset("SELECT * FROM tblProviderAggFinal ORDER BY Provider DESC", dbOpenDynaset)
start:

If rs.EOF = True Then
    GoTo endx
End If

Pcode = rs.Fields("SpecialtyCode")
If Len(Pcode) > 2 Then
    Pcode = Mid(Pcode, 1, 2)
        End If
        
charge = rs.Fields("SumOfChargeAmt")
    If Pcode = dbnum Then
        If charge >= 150000 Then
            pname = rs.Fields("Provider")
                Dim pagename As String
                    If InStr(pname, ",") > 0 Then
                        pagename = Mid(pname, 1, InStr(pname, ",") + -1)
                            Else
                                pagename = Mid(pname, 1, InStr(pname, ";") + -1)
                                    End If
    
    ws.Copy wb.sheets(1)
        wb.sheets(1).Name = pagename
            Set ws = wb.Worksheets(1)
                Dim testval As String
            
'                    testval = ""
'                        On Error Resume Next
'                            testval = ws.Range("a8").Value
'                                If InStr(testval, ",") > 0 Then
'                                    ws.Range("a8").Value = pname
'                                        GoTo edofset
'                                            End If
    
                                                testval = ""
                                                    On Error Resume Next
                                                        testval = ws.Range("a9").Value
                                                            If InStr(testval, ",") > 0 Then
                                                                ws.Range("a9").Value = pname
                                                                    GoTo edofset
                                                                        End If
    
                                                                        testval = ""
                                                                        On Error Resume Next
                                                                    testval = ws.Range("a10").Value
                                                                If InStr(testval, ",") > 0 Then
                                                            ws.Range("a10").Value = pname
                                                        GoTo edofset
                                                    End If
    
                                                testval = ""
                                            On Error Resume Next
                                        testval = ws.Range("a11").Value
                                    If InStr(testval, ",") > 0 Then
                                ws.Range("a11").Value = pname
                             GoTo edofset
                            End If
    
                        testval = ""
                    On Error Resume Next
                testval = ws.Range("a12").Value
            If InStr(testval, ",") > 0 Then
        ws.Range("a12").Value = pname
    GoTo edofset
    End If
    
    'Test for ; between the provider last name and first name
    testval = ""
        On Error Resume Next
            testval = ws.Range("a8").Value
                If InStr(testval, ";") > 0 Then
                    ws.Range("a8").Value = pname
                        GoTo edofset
                            End If
    
                                testval = ""
                                    On Error Resume Next
                                        testval = ws.Range("a9").Value
                                            If InStr(testval, ";") > 0 Then
                                                ws.Range("a9").Value = pname
                                                    GoTo edofset
                                                        End If
    
                                                            testval = ""
                                                                On Error Resume Next
                                                                    testval = ws.Range("a10").Value
                                                                    If InStr(testval, ";") > 0 Then
                                                                ws.Range("a10").Value = pname
                                                            GoTo edofset
                                                        End If
    
                                                    testval = ""
                                                On Error Resume Next
                                            testval = ws.Range("a11").Value
                                        If InStr(testval, ";") > 0 Then
                                    ws.Range("a11").Value = pname
                                GoTo edofset
                            End If
    
                        testval = ""
                    On Error Resume Next
                testval = ws.Range("a12").Value
            If InStr(testval, ";") > 0 Then
        ws.Range("a12").Value = pname
    GoTo edofset
    End If
edofset:


End If
End If

rs.MoveNext
GoTo start
endx:
 xlApp.Application.DisplayAlerts = False
    xlApp.Save
        xlApp.Application.DisplayAlerts = False
            xlApp.Application.Quit
 
GoTo stsq
errorx:
    status = "Error please contact your admin"
endsq:

'Saving Stage
 xlApp.Application.DisplayAlerts = False
    xlApp.Application.Quit
End Sub
 

Attachments

You installed office 2013!

Not sure what the code is there for unless its explained in a previous post?
 
I installed Office Pro 2016 I attached 2 documents.

Code: I have an excel template with 20+ tabs. Each tab is a two digits # that represent a specialty. For example Family Medicine is 08, Internal Medicine is 11. In my database I have a table called tblProvider with three fields, Provider, Licensure, and SpecialtyCode (two digit # from the spreadsheet). The code will generate a different spreadsheet for each specialty ex. Family Med, Internal Med, OG/GYN etc. If the specialtycode from tblProvider matches a tab in the Excel template a tab for that provider will get generated pulling in their data from tblBillingdata and then move to the next provider in that specialty. Once that specialty is completed the next group of specialties will get generated. If I open my other laptop with Office Pro 2010 and run the code everything work as it should. However when I take that same database and run it with my Office Pro 2016 it stops at the Excel Naming phase basically it will generate a Excel sheet for each specialty but not write the data. We are moving away from 2010 that is why i'm trying to run it with Office Pro 2016. Sorry for the long message
 
You must log in or register to reply here.

Similar threads

M
Solved MS office cannot find the field ... referred to in your expression.
Replies
14
Views
978
arnelgp
arnelgp
T
Solved form in navigation pane... is a pain ?
Replies
11
Views
364
TipsyWolf
T
D
Subform only shows single record
Replies
3
Views
189
arnelgp
arnelgp
mike60smart
Syntax
Replies
8
Views
291
Mark_
M
8
Enable/Disable shift open key IF
2
Replies
31
Views
617
823
8

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom