Creating a excel pivot table with a adomd.cellset - excel

Im developing with vba in excel and wanna create some excelsheets to render a pivot table and a chart.
I did it with recordset which was returned from a custom mdx query. I have a example below which returns the data from the cube into a recordset then creates a pivottable and a chart. Working like a charm.
Public Sub CreatePivotTableAndChart()
Dim MDXQuery As String
'Declare variables
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
On Error GoTo ErrorHandler
'Open Connection
conn.ConnectionString = "Provider=MSOLAP.7;Integrated Security=SSPI;Persist Security Info=True;Initial Catalog=xxxxxxx;Data Source=xxxxxxxx;MDX Compatibility=1;Safety Options=2;Protocol Format=XML;MDX Missing Member Mode=Error;Packet Size=32767"
conn.Open
'Custom MDX query
MDXQuery = "WITH" & vbCrLf & _
"MEMBER [Measures].[DateValue] AS [DT_dTime].[Date].MemberValue" & vbCrLf & _
"SELECT {[Measures].[DT_mTransactions_Count], [Measures].[DateValue]} ON COLUMNS," & vbCrLf & _
"(Filter([DT_dTime].[Date].[Date].ALLMEMBERS, [Measures].[DT_mTransactions_Count] > 0)) ON ROWS" & vbCrLf & _
"FROM ( SELECT ( { [DT_dTags_Gender].[ParentTagID].&[4061],[DT_dTags_Gender].[ParentTagID].&[4062] } ) ON COLUMNS" & vbCrLf & _
"FROM [DT_BizTrackCube])" & vbCrLf & _
"WHERE ([DT_dTime].[Month].&[2018-01-01T00:00:00], [DT_dTags_MeasureType].[ParentTagID].&[8])"
rs.Open MDXQuery, conn
'Create new pivot cache
Set ws = ThisWorkbook.Worksheets("TestPivotTable")
Set pc = ActiveWorkbook.PivotCaches.Create(SourceType:=xlExternal)
rs.MoveFirst
'Set recordset
Set pc.Recordset = rs
'Create new pivot table
Set pt = pc.CreatePivotTable(TableDestination:=ws.Range("A1"), TableName:="PivotTable")
'define pivotfields
pt.PivotFields("[Measures].[DateValue]").Orientation = xlRowField
pt.PivotFields("[Measures].[DT_mTransactions_Count]").Orientation = xlDataField
pt.ManualUpdate = False
'Create new pivot chart
Dim objShape As Shape
ActiveSheet.PivotTables("PivotTable").PivotSelect "", xlDataAndLabel, True
Set objShape = ActiveSheet.Shapes.AddChart2(227, xlLine)
With objShape
.Select
'Name formatting, position
.Name = "PivotChart"
.Left = Range("E1").Left
.Top = Range("E1").Top
.Width = 646
.Height = 300
'Titles
.chart.HasTitle = True
.chart.ChartTitle.Text = "Maand vergelijking"
.chart.Axes(xlCategory, xlPrimary).HasTitle = True
.chart.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Dagen"
.chart.Axes(xlValue, xlPrimary).HasTitle = True
.chart.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Leads"
End With
'Close recordset
rs.Close
'Reset recordset
Set rs = Nothing
'Close connection
conn.Close
'Reset connection
Set conn = Nothing
Done:
Exit Sub 'Exit to avoid error handler
ErrorHandler:
Debug.Print "ErrorHandler"
' Get VB Error Object's information
strTmp = "VB Error # " & Str(Err.Number)
strTmp = strTmp & vbCrLf & " Generated by " & Err.Source
strTmp = strTmp & vbCrLf & " Description " & Err.Description & vbCrLf
Debug.Print strTmp
End Sub
The only problem is with this solution I have flattenend result. I wanna use for example a mdx query with cross join so i can use row grouping (dimensions). The result is a multidimensional result.
I know that the cube returns a cellset but how can i create a pivot table from a cellset? Is that even possible. I found some examples how you can read a cellset and print the result to a flat table but
not one how to create a pivot table from it.
Hope you can help me out. Thanks in advance.

Related

Transposing Values In a Listbox

Good day,
I am trying to transpose the values added to my listbox via a query. Also does anyone have tips on how to get the column names on the Column Header. This is what the values in my listbox looks like:
Below is my code thus far:
Dim conn As New ADODB.Connection
Dim reCs As ADODB.Recordset
Dim tarSheet As Worksheet
Dim strbooK As String, strTar As String
Dim arTar As Range
strbooK = ThisWorkbook.Path & "\Excel_VBA.xlsm"
If opTar.Value = True Then
strTar = "SELECT TargetNumber as [Target Number] " & _
",TargetName as [Target Name] " & _
",TargetPrefix as [Target Nickname] " & _
",Count(TargetNumber) as [Number of Events] " & _
"FROM [Master$] " & _
"GROUP BY TargetNumber, TargetName, TargetPrefix " & _
"HAVING TargetNumber = '" & txt_search.Value & "';"
Set conn = New ADODB.Connection
conn.ConnectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strbooK & ";" & _
"Extended Properties='Excel 12.0 Xml;HDR=YES';"
conn.Open
Set reCs = New ADODB.Recordset
reCs.ActiveConnection = conn
reCs.Source = strTar
reCs.Open
With lbx_reCs
.BoundColumn = 1
.ColumnCount = 4
.ColumnHeads = True
.TextAlign = fmTextAlignCenter
.ColumnWidths = "136;136;136;136;"
.MultiSelect = fmMultiSelectMulti
' .RowSource = arTar.Address
.List() = reCs.GetRows
End With
'Releasing Objects
reCs.Close
conn.Close
End If
Thank you
As said in the titel you need no transpose of the values of the recordset, just use the column property of the listbox.
.Column = reCs.GetRows
For the other question you might look here. That seems not to be possible in case you have an array like in this case. On the other hand you also might want to look at this solution approach in the above mentioned post.

Load aggregate data from Excel into ADODB.RecordSet

I am trying to load data from an Excel file in a specific sheet into an ADODB.RecordSet via a VBA macro by using SQL SELECT command.
There are several columns on the Excel sheet, and I don't need all of them.
For example:
col.A = Surname, col.B = Name, col.C = IDPerson, [....columns that are not needed], Col.N = Boss
The purpose would be to get a recordset of aggregated data for:
col.C = IDPerson, col.N = Boss.
The fields highlighted in the image below.
I would like to have a RecordSet with the aggregated (non-repeating) data of the columns highlighted in yellow.
Obviously, this problem could also be solved by loading a matrix, but, in this case I would have to build a loading algorithm to "clean" any repetitions in the data and then later I would have to provide a search function with some loops.
So I thought that if I could load all the data I need by reading the WorkSheet as if it were a data table and then make a query on it to extract the data that I need and load everything in an ADODB.RecordSet would be much more efficient also for searching for data (filter data for example).
Below I report my code that loads all the data of my sheet:
Public Sub LoadRecordSet(ByVal LastRow As Long, ByVal LastCol As Integer)
Dim cnt As ADODB.Connection
Dim rsData As ADODB.Recordset
Dim strSQL As String
Dim strTMP As String
strTMP = Cells(LastRow, LastCol).Address
strTMP = Replace(strTMP, "$", "")
Set cnt = New ADODB.Connection
cnt.Mode = adModeRead
cnt.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ActiveWorkbook.FullName & ";" & _
"Extended Properties=""Excel 12.0 Macro;HDR=Yes;"";"
cnt.Open
strSQL = "SELECT * FROM [Sheet1$C2:" & strTMP & "]"
Set rsData = New ADODB.Recordset
With rsData
Set .ActiveConnection = cnt
.Source = strSQL
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open
End With
'TODO - Something with rsData for filtering or to research
'GC
If Not rsData Is Nothing Then
If rsData.State <> adStateClosed Then rsData.Close
Set rsData = Nothing
End If
If Not cnt Is Nothing Then
If cnt.State <> adStateClosed Then cnt.Close
Set cnt = Nothing
End If
End Sub
My question is: "What if I just want to load some columns as described above and aggregate them so they don't have repetitions in the data?"
For example if I want to load similar
SELECT [cod.fiscale], responsabile FROM [MySheet$A3:N480] GROUP BY [cod.fiscale], responsabile
It's possible?
Thank you so much.
I improved my code which is now working:
Public Sub CaricaDati()
Dim cnt As ADODB.Connection
Dim rsDati As ADODB.Recordset
Dim strSQL As String
Dim strTMP As String
Dim i As Integer
on Error GoTo Error_Handler
Range("A3").Select
g_BOLTS_UltimaRiga = LasRow
Call LastCol
strTMP = Cells(g_LastRow, g_LastCol).Address
strTMP = Replace(strTMP, "$", "")
Set cnt = New ADODB.Connection
cnt.Mode = adModeRead
cnt.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ActiveWorkbook.FullName & ";" & _
"Extended Properties=""Excel 12.0 Macro;HDR=Yes;"";"
cnt.Open
'strSQL = "SELECT * FROM [2$C2:" & strTMP & "]"
strSQL = "SELECT cf, responsabile FROM [2$C2:" & strTMP & "] GROUP BY cf, responsabile"
Set rsDati = New ADODB.Recordset
With rsDati
Set .ActiveConnection = cnt
.Source = strSQL
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open
End With
If Not (rsDati.BOF And rsDati.EOF) Then
strTMP = ""
For i = 0 To rsDati.Fields.Count - 1
strTMP = strTMP & rsDati.Fields(i).Name & ";"
Next i
Debug.Print strTMP
strTMP = ""
rsDati.MoveFirst
Do While Not rsDati.EOF
strTMP = ""
For i = 0 To rsDati.Fields.Count - 1
strTMP = strTMP & rsDati.Fields(i).Value & ";"
Next i
Debug.Print strTMP
rsDati.MoveNext
Loop
End If
Uscita:
On Error Resume Next
'GC
If Not rsDati Is Nothing Then
If rsDati.State <> adStateClosed Then rsDati.Close
Set rsDati = Nothing
End If
If Not cnt Is Nothing Then
If cnt.State <> adStateClosed Then cnt.Close
Set cnt = Nothing
End If
Exit Sub
Error_Handler:
On Error GoTo 0
MsgBox Err.Number & " - " & Err.Description, vbOKOnly + vbCritical, "ERRORE IMPREVISTO"
GoTo Uscita
End Sub

Importing Excel worksheet range to Ms Access Table

Good Afternoon,
I have created a Macro that uploads data to a access database ( both on my desktop). The problem is it I keep getting errors when I try to expand the range.
I presumed it would be something simple but seems to be something I am overlooking.
here is the code - basically I would like to include the column or set it to a dynamic range? can you please help?
Sub AccessCode()
Application.ScreenUpdating = False
Dim db As Database
Dim rs As DAO.Recordset
Set db = OpenDatabase("C:\Users\user\Desktop\Test Copy.accdb")
Set rs = db.OpenRecordset("Fact Table", dbOpenTable)
rs.AddNew
rs.Fields("GUID") = Range("g2").Value
rs.Fields("StageID") = Range("h2").Value
rs.Fields("Sync Date") = Range("i2").Value
rs.Fields("Forecast HP") = Range("j2").Value
rs.Fields("Owner Id") = Range("k2").Value
rs.Fields("Recent Modified Flag") = Range("L2").Value
rs.Fields("Upload Date") = Range("M2").Value
rs.Update
rs.Close
db.Close
Application.ScreenUpdating = True
MsgBox " Upload To PMO Database Successful."
End Sub
You can use a query instead of iterating through a recordset:
Sub AccessCode()
Application.ScreenUpdating = False
Dim db As Database
Dim rs As DAO.Recordset
Set db = OpenDatabase("C:\Users\user\Desktop\Test Copy.accdb")
db.Execute "INSERT INTO [Fact Table] ([GUID], [StageID], etc) " & _
"SELECT * FROM [SheetName$G:M] " & _
"IN """ & ActiveWorkbook.FullName & """'Excel 12.0 Macro;HDR=No;'"
End Sub
This has numerous advantages, such as often being faster because you don't have to iterate through all the fields.
If you would trigger the import from Access instead of Excel, you wouldn't even need VBA to execute the query.
Change the rs section to this one:
With rs
.addnew
!GUID = Range("g2").Value
!StageID = Range("h2").Value
'...etc
.Update
End With
MSDN source
Use the AddNew method to create and add a new record in the Recordset object named by recordset. This method sets the fields to default values, and if no default values are specified, it sets the fields to Null (the default values specified for a table-type Recordset).
After you modify the new record, use the Update method to save the changes and add the record to the Recordset. No changes occur in the database until you use the Update method.
Edit:
This is how your code should look like, when you change the rs section with the code above:
Sub AccessCode()
Application.ScreenUpdating = False
Dim db As Database
Dim rs As DAO.Recordset
Set db = OpenDatabase("C:\Users\user\Desktop\Test Copy.accdb")
Set rs = db.OpenRecordset("Fact Table", dbOpenTable)
With rs
.addnew
!GUID = Range("g2").Value
!StageID = Range("h2").Value
'...etc
.Update
.Close
End With
Application.ScreenUpdating = True
MsgBox " Upload To PMO Database Successful."
End Sub
Just thought I'd add in an alternative to #Erik von Asmuth's excellent answer. I use something like this in a real project. It's a little more robust for importing a dynamic range.
Public Sub ImportFromWorksheet(sht As Worksheet)
Dim strFile As String, strCon As String
strFile = sht.Parent.FullName
strCon = "Excel 12.0;HDR=Yes;Database=" & strFile
Dim strSql As String, sqlTransferFromExcel As String
Dim row As Long
row = sht.Range("A3").End(xlDown).row
Dim rng As Range
sqlTransferFromExcel = " Insert into YourTable( " & _
" [GUID] " & _
" ,StageID " & _
" ,[sync Date] " & _
" ,[etc...] " & _
" ) " & _
" SELECT [GUID] " & _
" ,StageID " & _
" ,[sync Date] " & _
" ,[etc...] " & _
" FROM [{{connString}}].[{{sheetName}}$G2:M{{lastRow}}]"
sqlTransferFromExcel = Replace(sqlTransferFromExcel, "{{lastRow}}", row)
sqlTransferFromExcel = Replace(sqlTransferFromExcel, "{{connString}}", strCon)
sqlTransferFromExcel = Replace(sqlTransferFromExcel, "{{sheetName}}", sht.Name)
CurrentDb.Execute sqlTransferFromExcel
End Sub

Syntax error with Excel VBA Execute CREATE TABLE

So I am working in Excel VBA as a front end calculator for some statistics testing. After going through all the steps I want to be able to save the raw data involved with the calculations. But the file would become far to large with the amount of data that will end up being used so I want to export to an Access database. I have most everything working for the information I can create premade tables for but I am having syntax problems with the CREATE TABLE feature.
Here's my code:
Private Sub EndAndExport_Click()
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim dbPath As String
Dim Tblname As String
'Single path name, position of the file should never change
dbPath = "\\qs-nas1\Data1\QA\Bottling Level Check Database.accdb"
'Connect to new database
Set cnn = New ADODB.Connection
'Protection against no information
If Sheet5.Range("A6").Value = "" Then
MsgBox "There is no data, please enter sample data"
Exit Sub
End If
'Opening the connection
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath & ";"
'Entering data into a pre-existing table
Set rst = New ADODB.Recordset
rst.Open "Bottling_Information", cnn, adOpenDynamic, adLockOptimistic, adCmdTable
rst.AddNew
rst.Fields("Lot") = Cells(1, 2).Value
rst.Fields("Manufacturing Date") = Cells(1, 4).Value
rst.Fields("Bottling Date") = Cells(1, 6).Value
rst.Fields("Bottle Fill Amount") = Cells(3, 2).Value
rst.Update
rst.Close
'Setting variable as new table names value
Tblname = Sheet5.Cells(1, 2).Value
'Attempting to create the new table with the afformentioned string
'Where I get my syntax error
With cnn
.Execute "CREATE TABLE " & Tblname & " ([MeasuredVolume] text(25), " & _
"[MeasuredWeight] text(25), " & _
"[CalculatedVolume] text(25))"
End With
'Rest of the code which should populate the newly created table
Set rst = New ADODB.Recordset
rst.Open " & Tblname & ", cnn, adOpenDynamic, adLockOptimistic, adCmdTable
For i = 1 To SampleLabel5
rst.AddNew
For j = 1 To 3
rst(Cells(1, j).Value) = Cells(i + 5, j + 1).Value
Next j
rst.Update
Next i
'Clearing the memory for my connection and recordset variables
Set rst = Nothing
Set cnn = Nothing
'Clears data that was exported
Sheet5.Range(Cells(6, 1), Cells(SampleLabel5 + 5, 4)).ClearContents
Sheet5.Cells(1, 2).ClearContents
Sheet5.Cells(1, 4).ClearContents
Sheet5.Cells(1, 6).ClearContents
Sheet5.Cells(3, 2).ClearContents
Sheet5.Cells(3, 5).ClearContents
Sheet5.Range("H3:J3").ClearContents
Sheet5.Range("H6:J6").ClearContents
Sheet5.Range("H8:J10").ClearContents
Sheet5.Range("H14:J14").ClearContents
Sheet5.Range("H17:J17").ClearContents
Sheet5.Range("H19:J21").ClearContents
Sheet1.Activate
End Sub
The error I am getting is:
Run-time error '-2147217900 (80040e14)':
Syntax error in CREATE TABLE statement.
The SQL statement
CREATE TABLE CSF1802/1 (
[MeasuredVolume] text(25),
[MeasuredWeight] text(25),
[CalculatedVolume] text(25)
)
is not valid due to the forward slash (/) in the table name. You need a statement of
CREATE TABLE [CSF1802/1] (
[MeasuredVolume] text(25),
[MeasuredWeight] text(25),
[CalculatedVolume] text(25)
)
To create that statement you need the VBA code
.Execute "CREATE TABLE [" & Tblname & "] ([MeasuredVolume] text(25), " & _
"[MeasuredWeight] text(25), " & _
"[CalculatedVolume] text(25))"

Excel data to Access DB - Get: Operation must use an updateable query Error

I am working on an Excel application which allows users to enter hours work through userforms and info is stored in a Access DB. I am new to excel and access connections. I am able to connect to the database but record is not saved/created due to a run-time error at the .Update command.
Run-Time Error '-2147467259 (80004005)': Operation must use an updatable query.
I have searched and searched and can't find a solution to this problem. I hope someone is able to help. (code below)
Sub Export_Data_Access_TI1()
Dim dbPath As String
Dim x As Long, i As Long
Dim nextrow As Long
Dim user As String
Dim NewSht As Worksheet
Dim strQuery As String
Dim recDate As String
Dim Week_Of As String
user = Sheet1.Range("A1").Text
On Error GoTo ErrHandler:
'Variables for file path and last row of data
dbPath = "H:\PROJECTS\CAI_DOT-Time Tracker\CAI_EMP_SignIn_Database.accdb"
nextrow = Cells(Rows.Count, 1).End(xlUp).Row
'Initialise the collection class variable
Set cnn = New ADODB.Connection
'Check for data
If Sheets(user).Range("A2").Value = "" Then
MsgBox " There is no data to send to MS Access"
Exit Sub
End If
cnn.Mode = adModeReadWrite
'cnn.Mode = adModeShareDenyNone
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
Set rst = New ADODB.Recordset 'assign memory to the recordset
rst.CursorLocation = adUseClient
rst.Open Source:="DATA", ActiveConnection:=cnn, _
CursorType:=adOpenKeyset, LockType:=adLockPessimistic, _
Options:=adCmdTable
'rst.Supports (adAddNew)
x = 2 'the start row in the worksheet
Do While Len(Sheets(user).Range("A" & x).Formula) > 0
With rst
.AddNew 'create a new record
.Fields("Date") = ActiveWorkbook.Sheets(user).Range("A" & x).Value
.Fields("Week_Of") = Sheets(user).Range("B" & x).Value
.Fields("Month") = Sheets(user).Range("C" & x).Value
.Fields("Name") = Sheets(user).Range("D" & x).Value
.Fields("Time_In") = Sheets(user).Range("E" & x).Value
.Fields("Time_Out") = Sheets(user).Range("F" & x).Value
.Fields("Time_In2") = Sheets(user).Range("G" & x).Value
.Fields("Time_Out2") = Sheets(user).Range("H" & x).Value
.Fields("Group") = Sheets(user).Range("I" & x).Value
.Fields("UniqueID") = Sheets(user).Range("J" & x).Value
.Fields("Comments") = Sheets(user).Range("K" & x).Value
.Update 'stores the new record
End With
x = x + 1 'next row
Loop
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
'communicate with the user
MsgBox " The data has been successfully sent to the access database"
'Update the sheet
Application.ScreenUpdating = True
'Clear the data
'Sheets(user).Range("A1:K1000").ClearContents
On Error GoTo 0
Exit Sub
ErrHandler:
'clear memory
Set rst = Nothing
Set cnn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export_Data"
End Sub
As I understand, DATA is a query in the remote accdb. If so, it should be updateable. See, for example this: Why is my query not updateable? for criterias. If this is a table, check if you have read-write rights on accdb and the file has no read-only attribute.

Resources