UtterAccess.com
X   Site Message
(Message will auto close in 2 seconds)

Welcome to UtterAccess! Please ( Login   or   Register )

Custom Search
 
   Reply to this topicStart new topic
> Excel Connection To Access Query, Access 2016    
 
   
Alexus
post Nov 27 2019, 11:56 PM
Post#1



Posts: 48
Joined: 11-August 10
From: Sydney


Hi..

I have a single table Access query with a calculated field calling a custom vba function.
I need to present the data, including the calculated field in a pivot table and chart, however Excel seems to limit connections to table data only.
If this is correct my next option would seem to be moving the vba function from access to excel, however i don't understand how this function could be added automatically to every row in the linked excel table in the same way as an access query. I can imagine creating the calculated field in the pivot table but is this the only way to achieve what seems to be a simple requirement?
If i could connect to the access query rather than table this would be so simple but cant seem to do this (I tried editing excel's connecting properties)
I appreciate as a one off this wouldn't be difficult however as the data will be updated regularly i'm hoping to setup a system whereby as the access data table grows i can simply refresh excel connection and the pivot table and chart will update.

I'd appreciate any advice if this process is possible.. thanks.
Go to the top of the page
 
theDBguy
post Nov 28 2019, 01:02 AM
Post#2


UA Moderator
Posts: 76,845
Joined: 19-June 07
From: SunnySandyEggo


Hi. I have no experience with this, so the only thing I could think of is to create a temp table for your Excel connection. Maybe you can even execute it from Excel as you refresh the data/connection. Are you able to post a sample db and Excel file showing what you mean?

--------------------
Just my 2 cents... "And if I claim to be a wise man, it surely means that I don't know" - Kansas
Access Website | Access Blog | Email
Go to the top of the page
 
Alexus
post Nov 28 2019, 05:09 AM
Post#3



Posts: 48
Joined: 11-August 10
From: Sydney


thanks DBGuy.. i've attached the database with a few sample records..i just want to get the query results as a table in excel where i can run a pivot and refresh this each month as new data is appended to the access table.

Not sure i understand the workflow you're suggesting for a temp table.
Attached File(s)
Attached File  Query_to_Excel.zip ( 29.66K )Number of downloads: 3
 
Go to the top of the page
 
GroverParkGeorge
post Nov 28 2019, 10:05 AM
Post#4


UA Admin
Posts: 36,177
Joined: 20-June 02
From: Newcastle, WA


I am not sure why you think you can't connect to an Access query from Excel. I frequently have done so.

I believe that there may be some problems if you try to connect to a filtered query in which the WHERE clause references another object, like a combo box on a form. However, a simple SELECT query with multiple joins should work just fine.

--------------------
My Real Name Is George. Grover Park Consulting is where I did business for 20 years.
How to Ask a Good Question
Beginning SQL Server
Go to the top of the page
 
GroverParkGeorge
post Nov 28 2019, 10:15 AM
Post#5


UA Admin
Posts: 36,177
Joined: 20-June 02
From: Newcastle, WA


In this case, I think the problem is that the query in your sample data base contains calculated fields. If I remove them from the query, I can link to it.

That means your idea of creating a table table which has the fields from this query--including the results of the calculations in those calculated fields--is the way to make this work.

--------------------
My Real Name Is George. Grover Park Consulting is where I did business for 20 years.
How to Ask a Good Question
Beginning SQL Server
Go to the top of the page
 
Alexus
post Nov 28 2019, 04:43 PM
Post#6



Posts: 48
Joined: 11-August 10
From: Sydney


Thanks Grover.. yes i can see now that if there are no calculated fields then the query is available in Excel.
Can you see a workflow where i import/append data to the table and the query results flows through to excel? I think you and DBGuy are saying that each month i need to manually transfer the new records from the query to a second table which is linked to excel or come up with some code to achieve this.. seems like it would be less work just managing the data in excel.
Go to the top of the page
 
WildBird
post Nov 28 2019, 05:49 PM
Post#7


UtterAccess VIP
Posts: 3,673
Joined: 19-August 03
From: Auckland, Little Australia


I work with Excel and Access a lot. I export data from Access to a 'template' Excel file, and this then has the pivots etc on it. means data is embedded in Excel, no need to have a network connection. Limited to number of rows, depending on your Excel version, but rarely have had an issue.

I have all this automated, if you need some code etc, let us know.

Cheers

--------------------
Beer, natures brain defragging tool.
Go to the top of the page
 
GroverParkGeorge
post Nov 29 2019, 09:47 AM
Post#8


UA Admin
Posts: 36,177
Joined: 20-June 02
From: Newcastle, WA


I'd probably do the data manipulation in Excel since that's where it ends up anyway.

Wildbird's idea of a template in Excel makes a lot of sense in that context.

George

--------------------
My Real Name Is George. Grover Park Consulting is where I did business for 20 years.
How to Ask a Good Question
Beginning SQL Server
Go to the top of the page
 
Alex_Y
post Nov 30 2019, 03:54 PM
Post#9



Posts: 3
Joined: 30-November 19



Many thanks Wildbird.. i'd appreciate your code if you don't mind.

Note my id has changed from Alexus (changed email address and have lost ability to login)

thanks
Go to the top of the page
 
WildBird
post Dec 1 2019, 03:34 PM
Post#10


UtterAccess VIP
Posts: 3,673
Joined: 19-August 03
From: Auckland, Little Australia


Hi Alex,

I have quite a bit of code. Will have to explain it.

I use an .ini file. This is simply a text file, extension .ini. This has the same name as the application and in the same folder. E.g.
WorkforcePlanning.accdb
WorkforcePlanning.ini

This has entries like location for error handling, but also template names and paths
CODE
WFPTemplatePath=H:\WFPLocal\Template\
WFPTemplateFile=WFPTemplate.xlsm
ErrorPath=U:\FakePath\HR\Workforce Insight\HR Data Analysis\WFPTool\


Make a excel file, named the same as the name in the ini file (e.g. WFPTemplate.xlsm).
I always have a 'Main' sheet, a front page basically. This has hyperlinks to all the sheets, and also a place where the date the file was created goes, so you can tell what version it is. There is more code for the users to get their own files - thats later.
Somewhere on the Main sheet, have a named range called 'ReportDate' somewhere. You can add new named ranges, such as FinancialYear, Location etc, and set them in the code the same way.

Now, in the Excel file, make new worksheets for each datasource/query you have. Lets say you you want to have CustomerAddresses. Create a query and name it "qryExpWFPCustomerAddresses". Note qry = query. Exp for Export. WFP is a process type - all optional, but having a consistent naming convention makes it easy, and modular so you can add new process types - e.g. I am doing WorkforcePlanning (WFP) and AgeDistAnalysis (ADA).
Name the new worksheet CustomerAdddressesData. For any new query you make, give it the same prefix e.g. qryExp & process type ('WFP'). qryExpWFPEmployeeHours would have a worksheet named EmployeeHoursData.
Having consistent naming convention means in Excel you can hide all the data sheets easily.
Worksheets do not need anything else, no heading etc, these are all added automatically.

Now in Access, add a new module

CODE
Option Compare Database
Option Explicit

Declare PtrSafe Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Function h()
DoCmd.Hourglass False
'Splash , , , True
End Function

Function GetCompName() As String
GetCompName = Environ("ComputerName")
End Function

Function GetUser() As String
   Dim RetVal As Integer
   Dim UserName As String
   Dim Buffer As String
   Buffer = String(25, " ")
   RetVal = GetUserName(Buffer, 25)
   UserName = Strings.Left(Buffer, InStr(Buffer, Chr(0)) - 1)
   GetUser = UserName
End Function
Function GetString(ByVal strSection As String) As String
'Date:          Monday, 13 January 2014 12:52:45 PM
'Author:        Stephen Cooper
'Email:         coop@XXXXX.com
'Ph:
'In parameters
'Output
'Description:
'Calls:
'Notes:
'Example:
On Error GoTo HandleError:
Dim intMouseType As Integer
Dim strErrorMsg As String
Dim varReturn As Variant
Dim intFileNo As Integer
Dim strResult As String
Dim strReadLine As String
Dim intPos As Integer
Dim strFile As String
Dim strIniName As String

DoEvents

strIniName = Left(CurrentProject.Name, InStr(CurrentProject.Name, ".") - 1) & ".ini"
strFile = CurrentProject.Path & "\" & strIniName

'Can change this to use the same name as the app, plus .ini if you want
If Dir(strFile) = "" Then
    MsgBox "File " & strFile & " could not be located", vbCritical, "File Error"
    GetString = ""
    GoTo ExitHere
End If 'Dir(strFile) = ""

intFileNo = FreeFile

Open strFile For Input As intFileNo
Do While Not EOF(intFileNo)
    Line Input #intFileNo, strReadLine
    intPos = InStr(1, strReadLine, "=") - 1
    If intPos = 0 Then
        Exit Do
    End If 'intPos = 0
    If UCase(Trim(Left(strReadLine, intPos))) = UCase(Trim(strSection)) Then
        strResult = Mid(strReadLine, intPos + 2)
        Exit Do
    End If 'strReadLine = "[" & strSection & "]"
Loop 'While Not EOF(intFileNo)

GetString = Trim(strResult)

ExitHere:
On Error Resume Next
'Close all recordsets etc here
varReturn = SysCmd(acSysCmdClearStatus)
Screen.MousePointer = intMouseType
Close #intFileNo
Exit Function

HandleError:
Select Case Err.Number
Case Else
    LogError "GetString|" & CurrentProject.Name & "|" & strErrorMsg & "|" & Err.Number & " - " & Err.Description & "| Line number " & Erl
    MsgBox strErrorMsg & " " & Err.Number & " " & Err.Description, vbInformation, "Error"
    GetString = False
    'DoCmd.Close acForm, strUpdateForm, acSaveNo
    Resume ExitHere
End Select

End Function

Sub LogError(Optional strErrorMsg As String)
'Date:      11th June 4:38 PM
'Author:    Stephen Cooper
'Email:     stephen.cooper@xxx.com.au
'Ph:        8963
'In parameters  -   strErrorMSg - A string with values of variables
'Output
'Description:   This will write to a pipe delimited text file all the errors and various
                'times, users etc.
'Notes:         'Error should have user name already.
'Example        LogError("SC5|3089 Object doesnt exist|strSQL = Delete * FROM tblNotHere")   )
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim strFileName As String
Dim strFilePath As String
Dim fso As Variant
Dim f As Variant
Dim strUserName As String

strUserName = GetUser
strFileName = "ErrorLog.txt"
strFilePath = CheckPath(GetString("ErrorPath"))

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(strFilePath & strFileName, ForAppending, True)

f.Write strUserName & "|" & strErrorMsg & "|" & Now & vbCrLf
f.Close
ExitHere:
    DoCmd.Hourglass False
    Exit Sub
HandleError:
    Select Case Err.Number
        Case Else
            MsgBox "Ironically there was an error in the error handler " & Err.Number & " " & Err.Description, vbInformation, "Error"
            Resume ExitHere
    End Select
End Sub

Function CheckPath(ByVal strPath As String) As String
'Checks to see if a path has a backslash. If so, leaves it, otherwise appends one
If Right(strPath, 1) = "\" Then
    CheckPath = strPath
Else
    CheckPath = strPath & "\"
End If
End Function

Sub WriteBlock(ByVal strFilePath As String)
'Date:      11th June 4:38 PM
'Author:    Stephen Cooper
'Email:     stephen.cooper@xxx.com.au
'Ph:        8963
'In parameters  -   strErrorMSg - A string with values of variables
'Output
'Description:   This will write a file with the username and date time. GetLatest will check the existence of the file. Wont open if the file is present - prevents users from trying to open latest file while it is being created
'Notes:
'Example

Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim strFileName As String
Dim fso As Variant
Dim f As Variant
Dim strUserName As String

strUserName = GetUser
strFileName = "Block.txt"

Set fso = CreateObject("Scripting.FileSystemObject")
'Delete if it exists, appending will still work
If fso.FileExists(strFilePath & strFileName) Then
    fso.DeleteFile strFilePath & strFileName
End If

Set f = fso.OpenTextFile(strFilePath & strFileName, ForAppending, True)
f.Write strUserName & "|" & Now

f.Close

ExitHere:
    DoCmd.Hourglass False
    Exit Sub

HandleError:
    Select Case Err.Number
        Case Else
            MsgBox "Error in WriteBlock " & Err.Number & " " & Err.Description, vbInformation, "Error"
            Resume ExitHere
    End Select
End Sub

Function Process() As Boolean
'Date:          Tuesday, 12 March 2019 12:31:59 PM
'Author:        Stephen Cooper
'Email:         coop@XXXXX.com
'Ph:
'In parameters
'Output
'Description:   Will process the data to WFP template
'Calls:
'Notes:
'Example:

On Error GoTo HandleError:

Process = True

Dim intMouseType As Integer
Dim strErrorMsg As String
Dim varReturn As Variant
Dim strTemplatePath As String
Dim strTemplateName As String
Dim strExportPath As String
Dim strNewFilename As String
Dim objFSO As Object
Dim objXLApp As Object
Dim objXLBook As Object
Dim strSQL As String
Dim strUser As String
Dim strCompName As String
Dim db As DAO.Database
Dim strProcessType As String
Dim lngProcessedID As Long
Dim strFilePath As String
Dim strXLVer As String
Dim strDateFormat As String
Dim strCurrentFY  As String
Dim strFileVer As String
Dim strQTR As String

Dim varNow As Variant

varNow = Now

intMouseType = Screen.MousePointer

DoCmd.Hourglass True

'Splash "ProcessWFP"

strTemplatePath = CheckPath(GetString("WFPTemplatePath"))
strTemplateName = GetString("WFPTemplateFile")
strExportPath = CheckPath(GetString("WFPExportPath"))
strNewFilename = Format(Now, "yyyymmddhhnnss") & " " & "WFPReport.xlsm"

Set db = CurrentDb

Set objFSO = CreateObject("Scripting.FileSystemObject")

'Add a record to the Processed table to audit it a bit
strUser = GetUser
strCompName = GetCompName
strProcessType = "WFP"
strFilePath = strExportPath & strNewFilename

strSQL = "INSERT INTO tblOutputProcessed (ProcessType, UserName, CompName, FilePath) VALUES('" & strProcessType & "', '" & strUser & "', '" & strCompName & "', '" & strFilePath & "')"

'Get an ID so it can be audited and updated etc
lngProcessedID = GetID(strSQL)

'Check file exists first
If Not objFSO.FileExists(strTemplatePath & strTemplateName) Then
    MsgBox "Could not find file " & strTemplatePath & strTemplateName & ". Please check path and name and try again", vbCritical
    Process = False
    GoTo ExitHere
End If 'Not objFSO.FileExists(strTemplatePath & strTemplateName)

'Now check if the file has been created before, if so, delete it
If objFSO.FileExists(strExportPath & strNewFilename) Then
    objFSO.DeleteFile strExportPath & strNewFilename
End If 'objFSO.FileExists(strExportPath & strNewFileName)

'Write a blocker here to stop users opening it when I am making a new one
WriteBlock strExportPath

'Sometimes overwrite doesnt work, so delete above to make sure
varReturn = SysCmd(acSysCmdSetStatus, "Copying template file")
objFSO.CopyFile strTemplatePath & strTemplateName, strExportPath & strNewFilename, True

'Now we have new file
Set objXLApp = CreateObject("Excel.Application")

'Make it non visible. Speeds it up
objXLApp.Application.Visible = False
varReturn = SysCmd(acSysCmdSetStatus, "Opening Excel file")
'Coop - 20/11/2014 - turn off events, so the file isnt looking for an ini file that isnt there yet.
objXLApp.EnableEvents = False

Set objXLBook = objXLApp.Workbooks.Open(strExportPath & strNewFilename, False, False)

'Coop 01/05/2019 - added some auditing so we know if users are looking at the same version
strDateFormat = Format(Now, "dd/mmm/yyyy hh:nn:ss AM/PM")

With objXLBook.Worksheets("Main")
    .Range("ReportDate") = Now()
End With 'objXLBook.Worksheets("Overview")

If Not PopulateDataSheet(objXLBook, "qryExpWFP", 1, lngProcessedID) Then
    Process = False
    GoTo ExitHere
End If 'Not PopulateDataSheet(objXLWorkbook)

objXLApp.Run "RunAll"

ExitHere:
On Error Resume Next
'Close all recordsets etc here
varReturn = SysCmd(acSysCmdClearStatus)
Screen.MousePointer = intMouseType
'Update the Processed Table
strSQL = "UPDATE tblOutputProcessed SET EndTime = #" & Now & "# WHERE OutputProcessedID = " & lngProcessedID
strErrorMsg = strSQL
db.Execute strSQL
db.Close
Set db = Nothing
objXLApp.EnableEvents = True
objXLApp.DisplayAlerts = False
objXLBook.SaveAs FileName:=strExportPath & strNewFilename
objXLBook.Close
Set objXLBook = Nothing
objXLApp.DisplayAlerts = True
Set objFSO = Nothing
DeleteBlock strExportPath
'Splash , , , True

Exit Function

HandleError:
Select Case Err.Number
Case Else
    LogError "Process|" & CurrentProject.Name & "|" & strErrorMsg & "|" & Err.Number & " - " & Err.Description & "| Line number " & Erl
    MsgBox strErrorMsg & " " & Err.Number & " " & Err.Description, vbInformation, "Error"
    Process = False
    'DoCmd.Close acForm, strUpdateForm, acSaveNo
    Resume ExitHere
End Select

End Function



Function GetID(ByVal strSQL As String) As Long
'Date:          Thursday, 08 January 2015 10:28:38 AM
'Author:        Stephen Cooper
'Email:         XXXXXXXX@xxxxxxx.com
'Ph:
'In parameters
'Output
'Description:   Will get the latest ID (primary key field) for a new record from a given table
'Calls:
'Notes:
'Example:

On Error GoTo HandleError:

Dim intMouseType As Integer
Dim strErrorMsg As String
Dim varReturn As Variant
Dim db As DAO.Database

intMouseType = Screen.MousePointer

DoCmd.Hourglass True

Set db = CurrentDb

strErrorMsg = strSQL

db.Execute (strSQL)

GetID = db.OpenRecordset("SELECT @@IDENTITY")(0)

ExitHere:
On Error Resume Next
'Close all recordsets etc here
varReturn = SysCmd(acSysCmdClearStatus)
Screen.MousePointer = intMouseType
Set db = Nothing
Exit Function

HandleError:
Select Case Err.Number
Case Else
    LogError "GetID|" & CurrentProject.Name & "|" & strErrorMsg & "|" & Err.Number & " - " & Err.Description & "| Line number " & Erl
    MsgBox strErrorMsg & " " & Err.Number & " " & Err.Description, vbInformation, "Error"
    GetID = False
    'DoCmd.Close acForm, strUpdateForm, acSaveNo
    Resume ExitHere
End Select

End Function


Function PopulateDataSheet(ByRef objXLBook As Object, ByVal strPrefix As String, ByVal intStartRow As Integer, Optional lngProcessedID As Long) As Boolean
'Date:          Wednesday, 05 November 2014 10:53:43 AM
'Author:        Stephen Cooper
'Email:         coop@XXXXX.com
'Ph:
'In parameters  strPrefix, start of querydef name, intStartRow what row to start on
'Output
'Description:   Will loop the queries and export to the workbook
'Calls:
'Notes:         Workbook template needs to have worksheets setup with name, and any associated macros
'Example:       PopulateDataSheet(objXLBook, "tblExpADP" & strOrg, 4, lngProcessedID)

On Error GoTo HandleError:

PopulateDataSheet = True

Dim intMouseType As Integer
Dim strErrorMsg As String
Dim varReturn As Variant
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim rst As DAO.Recordset
Dim strSheetName As String
Dim strHeader As String
Dim i As Integer
Dim strSQL As String
Dim strQdfName As String
Dim lngRecordCount As Long
Dim strRawSQL As String

intMouseType = Screen.MousePointer

DoCmd.Hourglass True

DoEvents

Set db = CurrentDb

For Each qdf In db.QueryDefs
    With qdf
        strQdfName = .Name
        If UCase(Left(strQdfName, Len(strPrefix))) = strPrefix Then
            strErrorMsg = strQdfName
            strRawSQL = .SQL
            Set rst = db.OpenRecordset(strQdfName)
            varReturn = SysCmd(acSysCmdSetStatus, "Populating Excel file: " & strQdfName)
            'Build header
            strHeader = ""
            With rst
                For i = 0 To rst.Fields.Count - 1
                    strHeader = strHeader & .Fields(i).Name & ","
                Next i
                'remove trailing comma
                strHeader = Left(strHeader, Len(strHeader) - 1)
            End With 'rst
            
            'Sheet name must equal the query name , minus the prefix
            strSheetName = Mid(strQdfName, Len(strPrefix) + 1) & "Data"
            
            With objXLBook.Worksheets(strSheetName)
                For i = 1 To rst.Fields.Count
                    'Build the header first
                    While InStr(1, strHeader, ",") > 1
                        .Cells(intStartRow, i) = Left(strHeader, InStr(1, strHeader, ",") - 1)
                        strHeader = Mid(strHeader, InStr(strHeader, ",") + 1)
                        i = i + 1
                    Wend 'InStr(1, strHeader, ".") > 1
                    'Put in last part of header
                    .Cells(1, i) = strHeader
                Next i
                
                'if processedID needed then add it here
                If lngProcessedID > 0 Then
                    rst.MoveLast
                    rst.MoveFirst
                    lngRecordCount = rst.RecordCount
                    
                    strSQL = "INSERT INTO tblOutputQuery(QueryName, RecordCount, OutputProcessedID, RawSQL) VALUES ('" & strQdfName & "', " & lngRecordCount & ", " & lngProcessedID & ", '" & strRawSQL & "')"
                    strErrorMsg = strSQL
                    db.Execute strSQL
                End If
                
                .Cells(intStartRow + 1, 1).CopyFromRecordset rst
            End With 'objXLBook.Worksheets(strSheetName)
            
        End If 'Left(.Name, 6) = "qryEXP"
    End With 'qdf
Next qdf 'In db.QueryDefs

ExitHere:
On Error Resume Next
'Close all recordsets etc here
varReturn = SysCmd(acSysCmdClearStatus)
Screen.MousePointer = intMouseType
rst.Close
Set rst = Nothing
db.Close
Set db = Nothing
Exit Function

HandleError:
Select Case Err.Number
Case 3021
    If strQdfName = "qryExpWFPForecastNewMovement" Then
        Resume Next
    End If
Case Else
    LogError "PopulateDataSheet|" & CurrentProject.Name & "|" & strErrorMsg & "|" & Err.Number & " - " & Err.Description & "| Line number " & Erl
    MsgBox strErrorMsg & " " & Err.Number & " " & Err.Description, vbInformation, "Error"
    PopulateDataSheet = False
    'DoCmd.Close acForm, strUpdateForm, acSaveNo
    Resume ExitHere
End Select

End Function


Sub DeleteBlock(ByVal strFilePath As String)
'Date:      11th June 4:38 PM
'Author:    Stephen Cooper
'Email:     stephen.cooper@xxx.com.au
'Ph:        8963
'In parameters  -   strErrorMSg - A string with values of variables
'Output
'Description:   This will delete the block file
'Notes:
'Example

Dim strFileName As String
Dim fso As Variant

strFileName = "Block.txt"

Set fso = CreateObject("Scripting.FileSystemObject")
'Delete if it exists, appending will still work
If fso.FileExists(strFilePath & strFileName) Then
    fso.DeleteFile strFilePath & strFileName
End If

ExitHere:
    DoCmd.Hourglass False
    Exit Sub

HandleError:
    Select Case Err.Number
        Case Else
            MsgBox "Error in WriteBlock " & Err.Number & " " & Err.Description, vbInformation, "Error"
            Resume ExitHere
    End Select
End Sub


Now, go back to the excel file, and add a sub called "RunAll". Save this file, and then in Access, run and step through
Process()
I think all the code is there. Like I said, I have lots of functions etc. Using this though, you should see that it is quite generic, and you can easily create a new data source and it will show up in the output file. I have used code that will create a new data worksheet if it wasnt already there, but I prefer to make them manually so I can see them in the template.

Running this code should produce a file with a date stamp in its name, with all the data for each query in a worksheet with the 'same' name.

Try this, and then I have lots of code for the Excel side. See if you can get this to work first though.

Good luck and any questions, let us know.








--------------------
Beer, natures brain defragging tool.
Go to the top of the page
 
Alex_Y
post Dec 2 2019, 02:44 AM
Post#11



Posts: 3
Joined: 30-November 19



Thank you Wildbird, appreciated.

i've created the structure and got through a couple of errors by:
> manually creating tblOutputProcessed so INSERT would work
> adding SLAExportPath to ini

Now there are no errors and the xls Main sheet is updated ok (reportdate), however the report file's query worksheet ('SLAData') is blank.

I'm not sure what the xls RunAll sub is doing, my research suggests i need to call macro names within the sub. Not sure if this is part of the problem, should i be adding a second sub in the xls?

I have attached the files, should you have a moment to check.

thanks again
Attached File(s)
Attached File  SLA.zip ( 74.07K )Number of downloads: 3
 
Go to the top of the page
 
WildBird
post Dec 2 2019, 03:24 PM
Post#12


UtterAccess VIP
Posts: 3,673
Joined: 19-August 03
From: Auckland, Little Australia


Hi Alex,

I forgot about the auditing - the tblOutputProcessed. You can see the structure though, I also have an OutputProcessedID field (autonumber, and a field called 'dDate' - default to Now())

Had a quick look, in Process(), try changing this line
CODE
If Not PopulateDataSheet(objXLBook, "qryExpWFP", 1, lngProcessedID) Then

to
CODE
If Not PopulateDataSheet(objXLBook, "qryExp", 1, lngProcessedID) Then


It would have been looking for queries beginning with qryExpWFP, you have qryExpSLA.

That should get you data populating into the output file.

RunAll, this is called from Access, and is run in the output file.

In the output file, the data sheets get populated, and then there are sheets that have buttons and pivot tables on them. The buttons rebuild the pivots, and I also have a Home button, this goes back to the main sheet. I often have quite a number of reports/pivots, and easy navigation to get home.

The rebuilding will go to the data sheet, and get the whole data set - so any new fields, or rows, will automatically show up. You can also go to the data pages, add a column, hit rebuild, and it will be available.

I name the Subs things like
SLAPivot
WFPPivot
BudgetPivot

RunAll is an easy way to group all these together, and run them, so when the file is opened, all the pivots are created and there is no waiting.

Also, are you in Sydney?

Cheers




--------------------
Beer, natures brain defragging tool.
Go to the top of the page
 
WildBird
post Dec 2 2019, 03:58 PM
Post#13


UtterAccess VIP
Posts: 3,673
Joined: 19-August 03
From: Auckland, Little Australia


Now, in the Excel 'template'.

Add a range "ErrorPath". Can be the same as the one in Access "C:\Users\XXXXXXXXXX\OneDrive - Macquarie Telecom Group\Desktop\Cabling\SLA\Errors"
O
Reason I dont use GetString like Access, is Excel file can be used anywhere, and I dont want to have an ini file following it around. Using a range, it will be self contained basically.

I also have a range ScreenUpdating, and have this True or False (I have a setup page with a number of options on it, and have data validations etc). Surprisingly, some people like seeing the screen update, others dont. I give them the option.

When you have a look at the below code, SLAPivot is the main bit.

This is where you it takes a bit of juggling. You need data to build the pivots, but you dont have data in the template, so you build stuff in the output file, and copy back to the template file. Makes sense once you do it a few times. Anyway, once you have the data populating to the output file, add a new sheet, name it SLA. Now, if you look at SLAPivot() you will notice that this will build a pvito table. However you will need to add your own field names. Some of it is generic, but other parts are specific. I commented these with Check this comment.

Easiest way, is to go to the data page, insert a pivot table, and once you start building what you want, record a macro. Note, change the macro output to name of the pivot table (PT! usually) and use wks, not ActiveSheet.

Couple of other things, your table is called "2019 Orders". I would rename it to tblOrders. As long as it has a date field, you can work out the year. Same as Holidays table.

Anyway, have a go and see what you come up with.

Cheers




--------------------
Beer, natures brain defragging tool.
Go to the top of the page
 
WildBird
post Dec 2 2019, 04:02 PM
Post#14


UtterAccess VIP
Posts: 3,673
Joined: 19-August 03
From: Auckland, Little Australia


CODE
Option Explicit

Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Function HideDataSheets() As Boolean
'Date:          Monday, 17 November 2014 3:35:07 PM
'Author:        Stephen Cooper
'Email:         coopersXXXXXXXXXXXXX
'Ph:
'In parameters
'Output
'Description:   This will go through and hide all the data sheets from showing
'Calls:
'Notes:
'Example:

On Error GoTo HandleError:

HideDataSheets = True

Dim intMouseType As Integer
Dim strErrorMsg As String
Dim varReturn As Variant
Dim sht As Worksheet

intMouseType = Application.Cursor

Application.Cursor = xlWait

Application.ScreenUpdating = False

For Each sht In ActiveWorkbook.Worksheets
    If Right(sht.Name, 4) = "Data" Then
        sht.Visible = xlSheetHidden
    End If
Next sht


ExitHere:
On Error Resume Next
'Close all recordsets etc here
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Cursor = intMouseType
Exit Function

HandleError:
Select Case Err.Number
Case Else
    LogError "HideDataSheets " & ThisWorkbook.Name & " " & strErrorMsg & " " & Err.Number & " - " & Err.Description & "  Line number " & Erl
    MsgBox strErrorMsg & " " & Err.Number & " " & Err.Description, vbInformation, "Error"
    HideDataSheets = False
    'DoCmd.Close acForm, strUpdateForm, acSaveNo
    Resume ExitHere
End Select

End Function


Function CheckPath(ByVal strPath As String) As String
'Checks to see if a path has a backslash. If so, leaves it, otherwise appends one
If Right(strPath, 1) = "\" Then
    CheckPath = strPath
Else
    CheckPath = strPath & "\"
End If

End Function


Sub LogError(Optional strErrorMsg As String)
'Date:      11th June 4:38 PM
'Author:    Stephen Cooper
'Email:     stephenXXXXXXX@xxxXXXXXXXXX
'Ph:        8963
'In parameters  -   strErrorMSg - A string with values of variables
'Output
'Description:   This will write to a pipe delimited text file all the errors and various
                'times, users etc.
'Notes:         'Error should have user name already.
'Example        LogError("SC5|3089 Object doesnt exist|strSQL = Delete * FROM tblNotHere")   )
Const ForReading = 1, ForWriting = 2, ForAppending = 8

Dim strFileName As String
Dim strFilePath As String
Dim fso As Variant
Dim f As Variant
Dim strUserName As String

strUserName = GetUser
strFileName = "ErrorLog.txt"
strFilePath = CheckPath(Range("ErrorPath"))

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(strFilePath & strFileName, ForAppending, True)

f.Write strUserName & "|" & strErrorMsg & "|" & Now & vbCrLf
f.Close

ExitHere:
    Application.Cursor = xlDefault
    Exit Sub
HandleError:
    Select Case Err.Number
        Case Else
            MsgBox "Ironically there was an error in the error handler " & Err.Number & " " & Err.Description, vbInformation, "Error"
            Resume ExitHere
    End Select
End Sub


Function GetUser() As String
   Dim RetVal As Integer
   Dim UserName As String
   Dim Buffer As String
   Buffer = String(25, " ")
   RetVal = GetUserName(Buffer, 25)
   UserName = Strings.Left(Buffer, InStr(Buffer, Chr(0)) - 1)
   GetUser = UserName
End Function


Function BuildPTC(ByVal strSource As String, ByVal strDestination As String, Optional strPTName As String) As Boolean
'Date:          Friday, 15 November 2019 10:37:00 AM
'Author:        Stephen Cooper
'Email:         coopXXXXXXXXXXX
'Ph:
'In parameters
'Output
'Description:   Will build a pivot table cache
'Calls:
'Notes:
'Example:

On Error GoTo HandleError:

BuildPTC = True

Dim intMouseType As Integer
Dim strErrorMsg As String
Dim varReturn As Variant
Dim strPTCacheName As String

intMouseType = Application.Cursor

Application.Cursor = xlWait

If Len("" & Trim(strPTName)) > 0 Then
    strPTCacheName = strPTName
Else
    strPTCacheName = "PT1"
End If

ThisWorkbook.PivotCaches.Create(xlDatabase, strSource, xlPivotTableVersion14).CreatePivotTable strDestination, strPTCacheName, , xlPivotTableVersion14

ExitHere:
On Error Resume Next
'Close all recordsets etc here
'varReturn = SysCmd(acSysCmdClearStatus)
Application.Cursor = intMouseType
Exit Function

HandleError:
Select Case Err.Number
Case Else
    LogError "BuildPTC|" & ThisWorkbook.Name & "|" & strErrorMsg & "|" & Err.Number & " - " & Err.Description & "| Line number " & Erl
    MsgBox strErrorMsg & " " & Err.Number & " " & Err.Description, vbInformation, "Error"
    BuildPTC = False
    'DoCmd.Close acForm, strUpdateForm, acSaveNo
    Resume ExitHere
End Select

End Function





Function ClearSheet(ByVal strSheetName As String) As Boolean
'Date:          Wednesday, 18 February 2009 9:50:56 AM
'Author:        Stephen Cooper
'Email:         stephen.cooper@XXXXXXXXXXX
'Ph:            23561
'In parameters
'Output
'Description:   Will delete the existing pivot data
'Calls:
'Notes:
'Example:

On Error GoTo HandleError:

ClearSheet = True

Sheets(strSheetName).Select
Rows("1:50000").Select
Selection.Delete Shift:=xlUp
Range("A1").Select

ExitHere:
On Error Resume Next
'Close all recordsets etc here
Exit Function

HandleError:
Select Case Err.Number
Case Else
    'MsgBox strErrorMsg & " " & Err.Number & " " & Err.Description, vbInformation, "Error"
    ClearSheet = False
Resume ExitHere
End Select

End Function




Function GetSource(ByVal strSheetName As String) As String
'Date:          Wednesday, 18 February 2009 10:02:05 AM
'Author:        Stephen Cooper
'Email:         stephen.cooper@XXXXXXXXXXX
'Ph:            23561
'In parameters
'Output
'Description:
'Calls:
'Notes:
'Example:

On Error GoTo HandleError:

GetSource = True

Dim intMouseType As Integer
Dim strErrorMsg As String
Dim varReturn As Variant
Dim lLastRow As Long
Dim lLastCol As Long
Dim i As Integer
Dim wks As Worksheet

'Need to make sure page is visible
Worksheets(strSheetName).Visible = xlSheetVisible

i = 1

Set wks = Sheets(strSheetName)

wks.Select
'Now that the data sheet has been selected, can get the special cells ie the end cells
lLastRow = ActiveSheet.Cells.SpecialCells(xlLastCell).Row
'lLastCol = ActiveSheet.Cells.SpecialCells(xlLastCell).Column
While Len(Trim(wks.Cells(1, i))) > 0
    i = i + 1
Wend

If i = 1 Then
    lLastCol = i
Else
    lLastCol = i - 1
End If 'i = 1

GetSource = strSheetName & "!R1C1:R" & lLastRow & "C" & lLastCol

ExitHere:
On Error Resume Next
'Close all recordsets etc here
Worksheets(strSheetName).Visible = xlSheetHidden
Exit Function

HandleError:
Select Case Err.Number
Case Else
    MsgBox strErrorMsg & " " & Err.Number & " " & Err.Description, vbInformation, "Error"
    GetSource = False
Resume ExitHere
End Select

End Function


Sub ColourIt(Optional strPTName As String)
Dim strStyle As String
Dim strPTCacheName As String

strStyle = Range("PivotTableStyle")

If Len(Trim("" & strStyle)) = 0 Then
    strStyle = "PivotStyleLightCustom"
End If 'Len(Trim("" & strStyle)) = 0

If Len("" & Trim(strPTName)) > 0 Then
    strPTCacheName = strPTName
Else
    strPTCacheName = "PT1"
End If

ActiveSheet.PivotTables(strPTCacheName).TableStyle2 = strStyle
ActiveSheet.PivotTables(strPTCacheName).ShowTableStyleRowStripes = True
ActiveSheet.PivotTables(strPTCacheName).ShowTableStyleColumnStripes = True

End Sub

Function GetStartRow() As String
'Will return the starting row and column to put Pivot table in
GetStartRow = "!R5C1"

End Function


Sub SLAPivot()
'Date:          Sunday, 02 August 2015 3:27:30 PM
'Author:        Stephen Cooper
'Email:
'Ph:
'In parameters
'Output
'Description:
'Calls:
'Notes:
'Example:

On Error GoTo HandleError:

Dim intMouseType As Integer
Dim strErrorMsg As String
Dim strSource As String
Dim strSheetName As String
Dim strStartRow As String
Dim wks As Worksheet
Dim strFY As String

intMouseType = Application.Cursor

Application.Cursor = xlWait

strSheetName = "SLA"

'Check
strFY = Range("FY")

'Check if screenupdating is on or off
If Range("ScreenUpdating") = "False" Then
    Application.ScreenUpdating = False
Else
    Application.ScreenUpdating = True
End If

Set wks = Worksheets(strSheetName)

ClearSheet strSheetName

strSource = GetSource(strSheetName & "Data")

'If no data returned, will be row 1, so no point continuing, goto exit
If Right(strSource, 9) = "R1C1:R1C1" Then
    GoTo ExitHere
End If

strStartRow = GetStartRow

'ThisWorkbook.PivotCaches.Add(xlDatabase, strSource).CreatePivotTable strSheetName & strStartRow, "PT1"
BuildPTC strSource, strSheetName & strStartRow
        
wks.Select

'Check from here
With wks.PivotTables("PT1").PivotFields("FY")
    .Orientation = xlPageField
    .Position = 1
End With

With wks.PivotTables("PT1").PivotFields("Type")
    .Orientation = xlRowField
    .Position = 1
End With

With wks.PivotTables("PT1").PivotFields("QTR")
    .Orientation = xlColumnField
    .Position = 1
End With

wks.PivotTables("PT1").AddDataField wks.PivotTables("PT1").PivotFields("FTEChange"), "Sum of FTEChange", xlSum

With wks.PivotTables("PT1").PivotFields("Sum of FTEChange")
    .NumberFormat = "0.00"
End With

wks.PivotTables("PT1").PivotFields("FY").ClearAllFilters
wks.PivotTables("PT1").PivotFields("FY").CurrentPage = strFY

wks.PivotTables("PT1").HasAutoFormat = False
'Check to here

ColourIt
    
ExitHere:
On Error Resume Next
'Close all recordsets etc here
ActiveWorkbook.ShowPivotTableFieldList = False
Application.CommandBars("PivotTable").Visible = False
Application.ScreenUpdating = True
Application.Cursor = intMouseType
Range("A1").Select
Exit Sub

HandleError:
Select Case Err.Number
Case 1004
    Resume Next
Case 438
    Resume Next
Case Else
    LogError "SLAPivot " & ThisWorkbook.Name & " " & strErrorMsg & " " & Err.Number & " - " & Err.Description
    MsgBox strErrorMsg & " " & Err.Number & " " & Err.Description, vbInformation, "Error"
Resume ExitHere
End Select

End Sub

--------------------
Beer, natures brain defragging tool.
Go to the top of the page
 
Alex_Y
post Dec 4 2019, 12:10 AM
Post#15



Posts: 3
Joined: 30-November 19



Fantastic Wildbird, thanks so much!!

fyi i did have one more tweak which was to create tblOutputQuery as there was an insert statement for this.
have renamed tables as suggested, agree much better.

thanks for the SLAPivot code.. i'll get to this next.

Yep im in Sydney..Northern Beaches.

thanks again!
Go to the top of the page
 


Custom Search


RSSSearch   Top   Lo-Fi    10th December 2019 - 08:02 AM