Once again, I advise using a true database for this type of work. Excel is not, nor is intended to be, a RDMS. Data can be easily corrupted/orphaned and updates to data can be horrible to complete.
Ok DavidAustin,
This is the revised code to return as described in my prior post. You should be able to take it from here. Please post back with any tweaks or improvements.
Also added a line to set the row header to something better than [Row Labels] default:
Remember not to duplicate line1 in your modules :)
This code has been tested in Office 2013 using the files as described in post#11
A few things I've thought of that I'll leave for later.
Lines 42 thru 48 are from the prior posting returning a simpler dataset. I've left them here for academic review - normally I would delete these in a production setting.
Ok DavidAustin,
This is the revised code to return as described in my prior post. You should be able to take it from here. Please post back with any tweaks or improvements.
Also added a line to set the row header to something better than [Row Labels] default:
Remember not to duplicate line1 in your modules :)
This code has been tested in Office 2013 using the files as described in post#11
A few things I've thought of that I'll leave for later.
+ Ideally the code would check for an existing connection to the "back-end" workbook and either delete that connection or modify the connection.
+ Using the file dialog ( insights>Select a File or Folder using the FileDialog Object ) one could allow the user some control to locate the desired file.
+Hmmm...
+ Using the file dialog ( insights>Select a File or Folder using the FileDialog Object ) one could allow the user some control to locate the desired file.
+Hmmm...
Code:
Option Explicit
Sub Example_MockRDMS()
'This code will make a connection to the specified workbook
'this workbook must have named ranges. In this case people_range and data_range
'the SQL relates the data from one range to the other.
'
Dim zWB As Workbook
Dim zCN As WorkbookConnection
Dim zPT As PivotTable
Dim zptsheet As Worksheet
Dim zFP As String
Dim zFN As String
Dim zDBQ As String
Dim zDefaultDir As String
Dim zSQL As String
Dim znewnames As String
Dim zemergency As Integer
'
On Error GoTo zerrortrap
'
Set zWB = ThisWorkbook
'
'
Set zptsheet = zWB.Worksheets.Add
'make sure the new sheet has a unique name
znewnames = "NewPT" & Format(Now(), "YYYY_MM_DD_HH_mm_ss")
zptsheet.Name = znewnames
'
'Here's where you'll want to seup your paths and file names.
'observe the format in each... it is importaint the the back-slashes be correct!
zFP = "C:\Users\[USERNAMEHERE]\Documents\_Databases_Programming\Bytes_Work\964602_excel_2010_MockRDMS"
zFN = "\" & "964602_excel_2010_MockRDMS_BackEnd.xlsx"
'
'build the connection string
zDBQ = "ODBC;DSN=Excel Files;" & _
"DBQ=" & zFP & zFN & _
";DefaultDir=" & zFP & _
";DriverId=1046;MaxBufferSize=2048;PageTimeout=5;"
'
'build the relational SQL for the named ranges in the mock backend database
'simple
'zSQL = "SELECT people_range.people_pk" & _
", people_range.People_LastName" & _
", data_range.data_pk, data_range.data_number" & _
" FROM data_range data_range, people_range people_range" & _
" WHERE people_range.people_pk = data_range.People_FK" & _
" ORDER BY people_range.People_LastName, data_range.data_pk"
'
'returns all of the last names in the named range people_range
zSQL = "SELECT people_range.people_pk" & _
", people_range.People_LastName" & _
", data_range.data_pk, data_range.data_number" & _
" FROM {oj people_range people_range" & _
" LEFT OUTER JOIN data_range data_range" & _
" ON people_range.people_pk = data_range.People_FK}" & _
" ORDER BY people_range.People_LastName, data_range.data_pk"
'
'Reuse the variable here to create a unique connection
znewnames = "DC_MockRDMS_BE" & Format(Now(), "YYYY_MM_DD_HH_mm_ss")
zWB.Connections.Add2 _
Name:=znewnames, _
Description:="Connection to ExcelFile as Mock RDMS backend", _
ConnectionString:=zDBQ, _
CommandText:=zSQL
'
'because I'm changing the connection names...
Set zCN = zWB.Connections.Item(znewnames)
'
'ok, now for the magic insert the new pivot table in to the newly created worksheet
'
'Reuse the variable here to create a unique connection
'technically, we can use the same name on different sheets so that PivotTable1 could be on twenty different
'worksheets... @_@
znewnames = "PvtTbl" & Format(Now(), "YYYY_MM_DD_HH_mm_ss")
zWB.PivotCaches.Create(SourceType:=xlExternal, _
SourceData:=zCN, _
Version:=xlPivotTableVersion15).CreatePivotTable TableDestination:=zptsheet.Cells(1, 1), _
TableName:=znewnames, _
DefaultVersion:=xlPivotTableVersion15
zptsheet.Cells(1, 1).Select
'
'make our life easier when refering to the new piviot table!
Set zPT = zptsheet.PivotTables(znewnames)
zPT.NullString = "0"
'
'OK... now here is where we start setting up the row, column, and field information.
'this is a very simple example.
With zPT.PivotFields("People_LastName")
.Orientation = xlRowField
.Position = 1
End With
'Change the rowheader title to something better than the default [row labels]
zPT.CompactLayoutRowHeader = "Last_Name"
'
zPT.AddDataField zPT.PivotFields("data_number"), "Sum_of_data_number", xlSum
'
'ok, hide the field list if visible... this worked in Excel2003 anbd in Excel2013...
If zWB.ShowPivotTableFieldList Then zWB.ShowPivotTableFieldList = False
'
zcleanup:
If Not zCN Is Nothing Then Set zCN = Nothing
If Not zptsheet Is Nothing Then Set zptsheet = Nothing
If Not zPT Is Nothing Then Set zPT = Nothing
If Not zWB Is Nothing Then Set zWB = Nothing
Exit Sub
zerrortrap:
Debug.Print "ErrS: " & Err.Source & vbCrLf & "ErrN: " & Err.Number & vbCrLf & "ErrD: " & Err.Description
'
'prevent errortrapping loops... sometimes Shifu's-an-idiot :)
If zemergency > 100 Then Exit Sub
zemergency = zemergency + 1
'
Resume zcleanup
End Sub
Comment