Excel Back In Black

No, not the classic rock album by the boys from AC/DC – Excel has a new black theme, and with a registry hack, you can give the Visual Basic Editor a black background – let’s take a look.

Office 365 Pro Plus Update

The Black Theme is only available for subscribers of Office 365. I’m using Office 365 Pro Plus and I had to jump through a few hoops to get the new black theme as well as the 6 new functions recently released for Excel:


  • Textjoin()
  • Concat()
  • Maxifs()
  • Minifs()
  • Ifs()
  • Switch()

I followed the steps listed on this site to set myself up for First Release through the Office 365 Admin Center. However, after 24 hours, I did not have the updates. I uninstalled Office 365 and reinstalled and voila! – update successful!

Office 365 Black Theme

To change the Office Theme:

ClickFileMenu

Click on the File Menu

OfficeAccount

Click on Account

OfficeTheme

Click on the Office Theme you like – I’m trying out the Black Theme. Giving a black background to the Visual Basic Editor is not as straight forward – it will require a bit of VBA with a registry hack.

VBE Black Background

The code below was posted by Belleye on reddit. You can see the original post here

Backup The Widows Registry

Below is some code that is changing Windows Registry settings. Before I start mucking around with the Registry, I’m going to create a backup in case things go awry.

Sub BackupRegistry()
'==========================================================================================================
'Author        : Belleye
'Link          : http://bit.ly/1Vkw8xg
'Modified by   : ws
'Backs up the VBA registry keys to C:\
'RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.0\Common\" ' Windows 10 Excel 2010
'RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.1\Common\" ' Windows 10 Office365 Pro Plus
'==========================================================================================================
    
Dim wsh As Object
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
Dim RegPath As String
Dim BackupFile As String

Set wsh = VBA.CreateObject("WScript.Shell")
    
' User defined variables
    RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.1\Common\" ' Windows 10 Office365 Pro Plus
    BackupFile = "C:\VBA_" & Format(Now, "yyyymmddhhmmss") & ".reg"

    wsh.Run "regedit.exe /e " & Chr(34) & BackupFile & Chr(34) & " " & Chr(34) & RegPath & Chr(34), windowStyle, waitOnReturn ' Export the registry key
    wsh.Run "Notepad.exe " & BackupFile ' Open backup in Notepad to show the key has been backed up

End Sub

Display Current VBE Colors

First, let’s look at the current color setting for the VBE:

Sub DisplayVBEColors()

'Exports the VBA editors colour scheme to the Immediate Window
'RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.0\Common\" ' Windows 10 Excel 2010
'RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.1\Common\" ' Windows 10 Office365 Pro Plus

Dim myWS As Object
Dim RegPath As String

Set myWS = CreateObject("WScript.Shell")
RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.1\Common\" ' Windows 10 Excel 2010

Debug.Print "ForeG = " & Chr(34) & myWS.RegRead(RegPath & "CodeForeColors") & Chr(34)
Debug.Print "BackG = " & Chr(34) & myWS.RegRead(RegPath & "CodeBackColors") & Chr(34)

End Sub

Results :

ForeG = “0 0 5 0 1 6 14 0 0 0 0 0 0 0 0 0 ”
BackG = “0 0 0 7 6 0 0 0 0 0 0 0 0 0 0 0 “

I’ll see if I can find the same information by navigating through the Registry Editor:

Registry

Looks good. Those are the settings to use if I want a white background and black text in the foreground.

VBEWhite

Next, I’ll set the VBE background to black

Change the VBE Background To Black

Sub SetVBEBackgroundToBlack()
'==========================================================================================================
'Author        : Belleye
'Link          : http://bit.ly/1Vkw8xg
'Modified by   : ws
'Comments      :
'              : RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.0\Common\" ' Windows 10 Excel 2010
'              : RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.1\Common\" ' Windows 10 Office365 Pro Plus
'              : Changes the VBA colour scheme according to the variables Foreg and BackG
'              : Requires Excel to be restarted
'==========================================================================================================

    Dim wsh As Object
    Set wsh = VBA.CreateObject("WScript.Shell")
    Dim waitOnReturn As Boolean: waitOnReturn = True
    Dim windowStyle As Integer: windowStyle = 1
    Dim RegPath As String
    Dim ForeG As String
    Dim BackG As String

    ' User defined variables
    RegPath = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\VBA\7.1\Common" ' Windows 10 Office365 Pro Plus no \ on the end

    ' Customise your colours here
    ForeG = "2 4 5 0 1 15 11 10 4 8 0 0 0 0 0 0 "
    BackG = "4 7 6 7 6 4 4 4 1 4 0 0 0 0 0 0 "

    wsh.Run "reg add " & RegPath & " /t REG_SZ /v CodeForeColors /d " & Chr(34) & ForeG & Chr(34) & " /f", windowStyle, waitOnReturn
    wsh.Run "reg add " & RegPath & " /t REG_SZ /v CodeBackColors /d " & Chr(34) & BackG & Chr(34) & " /f", windowStyle, waitOnReturn

End Sub

VBEBlack

Tidy Up

I have to admit – I’m not a fan. I switched back to the white background. But if that is your thing – go for it.

, , , , ,

OpenRowSetExcelArrowSQL

My grandparents had a small farm in Iowa . We only lived a few miles away and my brothers and I spent a great deal of time at the farm with our grandparents when we weren’t in school.

I traded the rolling corn fields of Iowa for the rusty-reddish brown soil of Arizona many years ago, but I frequently think about my grandparents and working around the farm with the crops, the garden, the animals and the machinery.

However, today’s post is not about feeding the chickens, or shucking the corn – it is about inserting data from Excel Worksheets to SQL Tables using the T-SQL Function OpenRowSet.


SQLServer

You’ll need SQL Server installed for this to work. I’m using SQL Server 2012 Developer on my laptop, but you could also use SQL Server Express which is free but limited in some of its functionality.

You can pick up a Developer copy of SQL Server 2014 Developer Edition from CDW. It will cost you ~ US $50. You can download SQL Server Express here. It’s free! However, you will need the Developer Edition if you want to do any testing with SSAS Tabular or Multidimensional.


Security300

You’ll need to change the default security for the SQL Server Instance you want to use the OpenRowSet Function on. I’ll use Windows Authentication instead of SQL Server Authentication.

Services1

  • Close SQL Management Studio if it is open.
  • Launch Services.msc. I’m using Windows 8.1 so I went to Search, typed in services and selected View Local Services
  • Jump to SQL Server by typing “S” and then scroll as needed until you find the instance of SQL Server that you want to change security settings.

ServicesClickStopFinal

  • Right-click on the Service and click on Stop.

ServicesClickProperties

  • Right-click on the Service and click on Properties.

PropertiesDialog

  • In the Properties Dialog, Click on the Logon Tab, enter your Windows Login information, Click OK.
  • Right-click on the Service and click on Start.

Settings

Depending on your system configuration, you may need to download and install the correct data connectivity components if you are using Excel 15.0 file formats (.xlsx etc…)

InsertFinal

I’ll use a SQL INSERT statement with the OpenRowSet Function to insert data from an Excel Worksheet to a table in my database

DataSample

Here is the Excel data source, so I’ll need to create a Table in my SQL Database with appropriate fields and data types to receive the data.

NewDatabase

I added a new database “Tecumseh” to my default instance of SQL Server. Now I can add a Table to the Database.

use tecumseh

CREATE TABLE scores
(
Reps nvarchar(50),
TrxDate date,
Region nvarchar(50),
Score float(53),
);

ScoresTableCreatedFinal

The Scores table with the required fields has been added to the Tecumseh database. Next, I’ll write some SQL to insert the data from the Scores.xlsx Workbook to the Scores table. Make sure the Excel file is closed or you will receive file exclusivity warnings.

USE tecumseh

INSERT INTO dbo.scores
SELECT *
FROM OPENROWSET('Microsoft.ACE.OLEDB.12.0',
	        'Excel 12.0 Xml;HDR=YES;Database=C:\data\scores.xlsx',
		'SELECT * FROM [sheet1$]');

The last step is to check that what is in the SQL Table matches what is in the Excel Workbook.

SQLResults

ExcelRows

Both The SQL Table and the Excel Workbook have 590 records! Sweet success!

Final Thoughts

That’s it for today. OpenRowSet and other functions (BULK INSERT) can be used in place of developing Integration Packages (SSIS). I receive many disconnected and disjointed files from a variety of sources each week/month. I prefer to clean everything up and move it to a database such as SQL or MS Access. Your thoughts?

, , , , ,

DustFinal3

The Dust Bowl ravaged the Great Plains from Canada down to Texas from 1930-1936/1940. On May 9, 1934, a large storm arose in the Great Plains pushing 350 million tons of topsoil more than 10K feet high, and carried it all the way out to the Atlantic Ocean leaving 1/4 inch of soil on ships off the coast on May 11.

The History Channel produced a show, aptly named “Black Blizzard”, that does an excellent job of presenting the causes, the effects and some of the remedies of the Dust Bowl – Check it out. If you cannot find it on the History Channel, check your favorite used bookstore or Amazon – well worth it.

Today’s post, however, is not about drought, proper farming techniques or plagues of grasshoppers – it is about pushing reporting to Excel. In my previous post on pushing reports to Excel, I showed you how to push reporting from an Excel Workbook to a new Workbook.

An admirable goal for sure, as it separates the presentation layer from the data and business tiers. Today, I will look at how we might push reports to Excel from Access.

Data Prep

First I’ll need to create a Table in an Access Database and define the datatypes for each of the fields.

Push2_1

Now I can upload the data from the Excel Workbook to the Table in Access

Push2_2

Now that I have the data from the Excel Workbook in the Access Table, I want to change the dates so I can test the dynamic nature of the code I introduced in my last post to ensure that as the dates change, the Group Method work properly on transaction dates in the Pivot Table. I will add 2 months to the original transaction dates by using the DateAdd Function in Access.


 

Read more on the DateAdd Function here

 


The SQL View of the Query:

SELECT Region,
       Rep,
       TrxDate,
       Score,
       DateAdd("m",2,[trxDate]) AS NewDate
FROM tblPush;

Not I’ll turn that into a Make Table Query to create a new Table named tblPushRev

SELECT Region,
       Rep,
       Score,
       DateAdd("m",2,[trxDate]) AS NewDate
INTO tblPushRev
FROM tblPush;

 

Use the SQL clause SELECT INTO to make a new table. Use INSERT INTO to append to an existing table.

 


 

Push2_3

Looking good, all of the original dates have been incremented by 2 months. Now I need to add a new Field named TrxDate, Copy the values from NewDate to TrxDate and remove the field “NewDate”.

Add a new Field named TrxDate and set the datatype to “Date”

ALTER TABLE tblPushRev
ADD TrxDate Date;

Then I can update the values of TrxDate from NewDate

UPDATE tblPushRev
SET TrxDate = NewDate

And remove the NewDate Field

ALTER TABLE tblPushRev
DROP COLUMN NewDate;

Here’s the revised table:

Push2_4

Now that I have the data I want in an Access Table, I need to create a query that I can output as my data source to be used for an Excel Table (ListObject Object). However, what if I have 2 different queries that I want to choose from as my data source? What if I have 10…20….etc? I’ll see if I can create a Query Picker so the user can choose a query at run-time to return the desired data to be used for the Pivot Table in Excel.

Add A Form

First, I’ll add a blank form to my database

frmQueryPicker

I added a blank form and saved it as frmQueryPicker.

Form Properties

PropertySheet

With the form active and in design mode, I clicked on the Property Sheet Icon on the Ribbon and set these form properties:

  • Caption: QueryPicker
  • Default View: Single Form
  • Record Selector: No
  • Navigation Buttons: No
  • Control Box: Yes
  • Min Max Buttons: None
  • Pop Up: Yes

Add A ListBox

ListBox

I added a ListBox to the form and with the form in design mode, I set the properties of the ListBox:

  • Column Count: 1
  • RowSource Type: Table/Query
  • Bound Column: 1
  • On Dbl Click: [Event Procedure]

I also need to add some SQL code to the RowSource Property:

SELECT MSysObjects.Name
FROM MSysObjects
WHERE (((MSysObjects.Type)=5) AND ((MSysObjects.Name) Not Like "~*"))
ORDER BY MSysObjects.Name;

 

MSysObjects are MS Access System Tables. More on MSysObjects here

 


MSysObjects.Type)=5 tells the SQL query to only return items that are query objects. Not Like “~*” tells the SQL Query to ignore hidden System Queries.

ListBoxWQueries

Note that the 3 queries visible as objects in the Access Navigation Pane are now listed in the ListBox.

Command Button…Open Query

Next, I’ll add a Command Button to my form that can be clicked to open the selected query

  • Name: cmdOpen
  • Column Count: 1
  • RowSource Type: Table/Query
  • Bound Column: 1
  • On Click: [Event Procedure]

CmdQryOpen

Command Button…Cancel

I’ll add another Command Button to my form so that I can cancel the form:

  • Name: cmdCancel
  • Caption: Cancel
  • Picture: (none)
  • On Click: [Event Procedure]
  • ControlTip Text: Cancel

CmdCancel

CheckBox AutoClose

The last control I would like to add to the form, is a check box to control whether the form should close or not after the query runs:

  • Name: chkAutoClose
  • Default Value: True

And the check box label:

  • Name: lblAutoClose
  • Caption: Close after opening Query

frmCheckBox

Code The Form

Now I need to add a bit of code behind the form so that all of the controls function as intended. First I need a sub to run whichever query the user selected as well as close the form after the query runs if the check box is “ticked”

CodeBehind3

  1. Make sure the form is active and in design mode. Right-click on the black box on the upper left corner of the form.
  2. In the resulting pop-up menu, click on “Build Event”
  3. In the resulting, “Choose Builder” dialog window, click on “Code Builder”

FormCodeModule

This will take you to the code module for the form. Note that the default event that came up is the Form Load Event. I don’t need that in this case, so I’ll change the control drop-down to General. Now I’ll create a Sub() to open the selected query and if the check box is ticked, close the form.

Option Explicit

Private Sub OpenQuery()
 
    'Declare variables
        Dim strQueryName As String
     
    'Open selected query
        strQueryName = Nz(Me.lstQueries.Value, "")
        If Len(strQueryName) > 0 Then DoCmd.OpenQuery strQueryName
        
    'Close form
        If Me.chkAutoClose.Value = True Then DoCmd.Close acForm, Me.Name
 
End Sub

Now I’ll add the event handlers for the Command Button Click-Events and the Double-click event for the ListBox:

Cancel Button Click Event:

Private Sub cmdCancel_Click()
    
    'if the user clicks the cancel button, close the form
        DoCmd.Close acForm, Me.Name
    
End Sub

Open Button Click Event:

Private Sub cmdOpen_Click()
    
    'Call the OpenQuery Sub()
    'Will open the selected query
        CreateReport
End Sub

ListBox Double Click Event:

Private Sub lstQueries_DblClick(Cancel As Integer)
    
    'Call the OpenQuery Sub()
    'Will open the selected query
        CreateReport
        
End Sub

FormRun

I ran the process by double-clicking on the “qryExcelData” query in the ListBox. The query results are displayed and the form closed as expected. I opened the form again in the foreground just for purposes of the screen shot.

All of the Access Tables, Queries, Forms, and VBA are complete, tested and working properly.

BullwinkleFinal2

And Now For Something Completely Different…

I’m no magician. I cannot pull Rocky out of a magic hat as Bullwinkle is doing here. But I might be able to push Excel reporting from MS Access.


 

edit: As is my usual practice, I am going to use Late Binding in the sample snippets below. A discussion on Late / Early Binding is beyond the scope of this post. Please see these links for a detailed explanation of Late / Early Binding.

  1. Beyond Excel
  2. JP Software Technologies

 


 

Excel Constants

Because I am using Late Binding, Access will not have knowledge of Excel Type Enumerations, so I will need to add several Constants to my project. I won’t use all of the constants below in this project, but since I was looking up the various Types below, I went ahead and created constants for the full Enumerations for each Type:

'XlListObjectSourceType Enumeration (Excel)
'Info: https://msdn.microsoft.com/en-us/library/office/ff820815.aspx
'-------------------------------------------------------------------
Public Const gclxlSrcExternal As Long = 0       'External data source (Microsoft SharePoint Foundation site).
Public Const gclxlSrcModel As Long = 4          'PowerPivot Model
Public Const gclxlSrcQuery As Long = 3          'Query
Public Const gclxlSrcRange As Long = 1          'Range
Public Const gclxlSrcXml As Long = 2            'XML


'XlReferenceStyle Enumeration (Excel)
'Info: https://msdn.microsoft.com/en-us/library/office/ff821207.aspx
'---------------------------------------------------------------------
Public Const gclxlA1 As Long = 1                'Default. Use xlA1 to return an A1-style reference.
Public Const gclxlR1C1 As Long = -4150          'Use xlR1C1 to return an R1C1-style reference.

'XlPivotTableSourceType Enumeration (Excel)
'Info: https://msdn.microsoft.com/en-us/library/office/ff836220.aspx
'-----------------------------------------------------------------------
Public Const gclxlConsolidation As Long = 3     'Multiple consolidation ranges.
Public Const gclxlDatabase As Long = 1          'Microsoft Excel list or database.
Public Const gclxlExternal As Long = 2          'Data from another application.
Public Const gclxlPivotTable As Long = -4148    'Same source as another PivotTable report.
Public Const gclxlScenario As Long = 4          'Data is based on scenarios created using the Scenario Manager.


'XlPivotFieldOrientation Enumeration(Excel)
'Info: https://msdn.microsoft.com/en-us/library/office/ff835617.aspx
'-----------------------------------------------------------------------
Public Const gclxlColumnField As Long = 2       'Column
Public Const gclxlDataField As Long = 4         'Data
Public Const gclxlHidden As Long = 0            'Hidden
Public Const gclxlPageField As Long = 3         'Page
Public Const gclxlRowField As Long = 1          'Row

'XlConsolidationFunction Enumeration(Excel)
'Info: https://msdn.microsoft.com/en-us/library/office/ff837374.aspx
'-----------------------------------------------------------------------
Public Const gclxlAverage As Long = -4106       'Average.
Public Const gclxlCount As Long = -4112         'Count.
Public Const gclxlCountNums As Long = -4113     'Count numerical values only.
Public Const gclxlDistinctCount As Long = 111   'Count using Distinct Count analysis.
Public Const gclxlMax As Long = -4136           'Maximum.
Public Const gclxlMin As Long = -4139           'Minimum.
Public Const gclxlProduct As Long = -4149       'Multiply.
Public Const gclxlStDev As Long = -4155         'Standard deviation, based on a sample.
Public Const gclxlStDevP As Long = -4156        'Standard deviation, based on the whole population.
Public Const gclxlSum As Long = -4157           'Sum.
Public Const gclxlUnknown As Long = 1000        'No subtotal function specified.
Public Const gclxlVar As Long = -4164           'Variation, based on a sample.
Public Const gclxlVarP = -4165                  'Variation, based on the whole population.

Is Excel Running Or Create Excel

First, I’ll create a Function to check whether Excel is already running or not. If Excel is running – use that instance, otherwise, create a new instance of Excel:

Option Explicit

Public Function GetXlApp() As Object

    'Get Excel Application

    'Declare objects
        Dim xlApp As Object
        
    'Check if app is already running, if not, create app
        On Error Resume Next                                                            '
        Set xlApp = GetObject(, "Excel.Application")
        If Err Then
            Set xlApp = CreateObject("Excel.Application")
        End If
        On Error GoTo 0
        
    'Pass object to function
        Set GetXlApp = xlApp
        
    'Tidy up
        Set xlApp = Nothing
            
End Function

Now that I have an instance of Excel, I need to add a Workbook to that instance:

Option Explicit

Public Function GetXlWorkbook(xlApp As Object) As Object

    'Add a workbook to the instance of Excel
    'Returns an Excel Workbook Object

    'Declare objects
        Dim xlBook As Object
        
    'Error handler
        On Error GoTo ErrHandler
        
    'Add a workbook
        Set xlBook = xlApp.Workbooks.Add
        
    'Pass object to function
        Set GetXlWorkbook = xlBook
        
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get workbook", Err.HelpFile, Err.HelpContext
        
    'Tidy up
        Set xlBook = Nothing
            
End Function

Now that I have a Workbook, I need a Worksheet to hold the data that I am going to export from Access:

Option Explicit

Public Function AddWorksheet(wb As Object, _
                             strSheetName As String) As Object
 
    'Declare variables
        Dim ws As Object
        Dim strMySheetName As String
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Add worksheet
        With wb
            Set ws = .Sheets.Add(After:=.Sheets(wb.Sheets.Count))
            ws.Name = strSheetName
        End With
 
    'Pass object to function
        Set AddWorksheet = ws
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Add a worksheet", Err.HelpFile, Err.HelpContext
 
    'Tidy up
        Set ws = Nothing
 
End Function

Now that I have a Worksheet, I need a Range to output the query results to:

    'Small snippet of main procedure
    'Get Excel Range
        Set xlRange = xlWorksheetData.Range("A2")

Transfer Data From DAO Recordset To Excel

As part of my main procedure I load the results of the user-selected query into a DAO Recordset. The entire main procedure is at bottom. Here is the DAO Recordset snippet:

 'Get database, query definition and recordset objects
        Set db = CurrentDb
        Set qdf = db.QueryDefs(strQueryName)
        Set rs = qdf.OpenRecordset

Now I can use the CopyFromRecordset Method of the Range Object to copy the query results from Access to Excel:

'Small snippet of main procedure   
'Copy the recordset to the Excel Range
        xlRange.CopyFromRecordset rs

The CopyFromRecordset Method only copies the records of the recordset, not the Field Headers, so I need to copy those to the Excel Worksheet separately:

'Small snippet of main procedure
'Copy field headers from the recordset to the Excel Worksheet
        For i = 1 To rs.Fields.Count
            xlWorksheetData.Cells(1, i).Value = rs.Fields(i - 1).Name
        Next i

QryToExcelRange

The selected query has been output to an Excel Worksheet (inset).

Add A ListObject To The New Range

I want to use a ListObject (Excel Table) as the data source for a Pivot Cache, so I’ll add a ListObject directly over the Range Object:

Option Explicit

Public Function GetListObject(ws As Object)
 
    'Declare objects
        Dim rng As Object
        Dim C As Object
        Dim lo As Object
        Dim xlSrcRange As Object
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Create range object
        Set rng = ws.UsedRange
        Set C = rng.Cells(1, 1)
 
    'Add listobject
        Set lo = ws.ListObjects.Add( _
                        SourceType:=gclxlSrcRange, _
                        Source:=rng, _
                        Destination:=C)
 
    'Pass the object to the function
        Set GetListObject = lo
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get ListObject", Err.HelpFile, Err.HelpContext
 
    'Tidy up
        Set lo = Nothing
        Set C = Nothing
        Set rng = Nothing
 
End Function

Add A Pivot Cache

I just added a ListObject (Excel Table). I’ll use that as the data source for a Pivot Cache:

Option Explicit

Public Function GetPivotCache(wb As Object, _
                              lo As Object)
 
    'Declare Objects
        Dim pc As Object
    
    'Declare variables
        Dim strPivotCacheSource As String
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Pivot cache source
        strPivotCacheSource = lo.Parent.Name & "!" & _
                              lo.Range.Address(ReferenceStyle:=gclxlR1C1)
 
    'Create pivot cache
        Set pc = wb.PivotCaches.Create( _
                        SourceType:=gclxlDatabase, _
                        SourceData:=strPivotCacheSource)
 
    'Pass object to function
        Set GetPivotCache = pc
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get pivot cache", Err.HelpFile, Err.HelpContext
 
    'Tidy up
        Set pc = Nothing
 
End Function

Add A Worksheet For The Pivot Table Report

Now that I have a Pivot Cache, I need to add a Worksheet for the Pivot Table Report:

Option Explicit

Public Function AddWorksheet(wb As Object, _
                             strSheetName As String) As Object
 
    'Declare variables
        Dim ws As Object
        Dim strMySheetName As String
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Add worksheet
        With wb
            Set ws = .Sheets.Add(After:=.Sheets(wb.Sheets.Count))
            ws.Name = strSheetName
        End With
 
    'Pass object to function
        Set AddWorksheet = ws
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Add a worksheet", Err.HelpFile, Err.HelpContext
 
    'Tidy up
        Set ws = Nothing
 
End Function

Add A Pivot Table

Now that I have a Worksheet, I can add a Pivot Table:

Option Explicit

 Public Function GetPivotTable(pc As Object, _
                              ws As Object, _
                              strPivotTableName As String, _
                              Optional ByVal lngRowPlacement As Long = 3, _
                              Optional ByVal lngColPlacement As Long = 3)
 
    'Declare Objects
        Dim pt As Object
        Dim rng As Object
 
    'Declare variables
        Dim strPivotPlacement As String
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Create range
        Set rng = ws.Cells(lngRowPlacement, lngColPlacement)
 
    'Pivot table placement
        strPivotPlacement = ws.Name & "!" & _
                            rng.Address(ReferenceStyle:=gclxlR1C1)
 
    'Create pivot table
        Set pt = pc.CreatePivotTable( _
                    TableDestination:=strPivotPlacement, _
                    TableName:=strPivotTableName)
 
    'Pass object to function
        Set GetPivotTable = pt
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get pivot table", Err.HelpFile, Err.HelpContext
 
    'Tidy up
        Set rng = Nothing
        Set pt = Nothing
 
End Function

Add Pivot Fields To Pivot Table

Now that I have a Pivot Table, I can add Pivot Fields. I am using a Select Case Statement to handle the correct Pivot Fields based on the name of the query the user selected. You will need to add additional Case Statements as you add more queries that require different fields and different consolidation functions (see global constants above):

Option Explicit

Public Sub AddFieldsToPivot(pt As Object, _
                            strQuery As String)
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Add fields to pivot table
        With pt
            Select Case strQuery
                Case "qryExcelData"
                   'Row fields
                       .PivotFields("Region").Orientation = gclxlRowField
                       .PivotFields("Region").Position = 1
        
                       .PivotFields("Reps").Orientation = gclxlRowField
                       .PivotFields("Reps").Position = 2
           
                   'Column fields
                       .PivotFields("TrxDate").Orientation = gclxlColumnField
                       .PivotFields("TrxDate").Position = 1
        
                   'Value fields
                       .AddDataField .PivotFields("Score"), _
                           Caption:="Avgerage of Score", _
                           Function:=gclxlAverage
                Case Else
                    MsgBox "The selected query is not an option for a Pivot Table"
                    Err.Raise 513                                                       'Custom error
            End Select
        End With
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get pivot table fields", Err.HelpFile, Err.HelpContext
        Err.Clear
 
End Sub

PivotFields

Group Dates By Month

Notice that the Pivot Table currently displays each day in a Column Field. I would prefer to group the dates based on the month. I can achieve this by using the Group Method of the Range Object. So first I will need to find the Range to group.

Get A Range From A Pivot Table

I need to get the first Cell in the PivotField “TrxDate” DataRange, so I’ll use the Pivot Item DataRange.


 

Read more on various ranges within a pivot table and their special VBA range names on Jon Peltier’s site

 


Option Explicit

Public Function GetPivotTableRange(pt As Object, _
                                   strRangeType As String, _
                                   Optional ByVal strPivotField As String = vbNullString) As Object
 
    'Pivot field Range type documentation:
    'http://peltiertech.com/referencing-pivot-table-ranges-in-vba/                  <-Jon Peltier
 
    'String range types:
        'PivotItemDataRange
        'DataBodyRange
 
    'Declare objects
        Dim rng As Object
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Create pivot table range
        Select Case strRangeType
            Case "PivotItemDataRange"
                Set rng = pt.PivotFields(strPivotField).DataRange.Cells(1, 1)
            Case "DataBodyRange"
                Set rng = pt.DataBodyRange
            Case Else
                MsgBox "That is not an option"
                Err.Raise 513
        End Select
 
    'Pass object to function
        Set GetPivotTableRange = rng
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get pivot table range", Err.HelpFile, Err.HelpContext
 
    'Tidy up
        Set rng = Nothing
 
End Function

Note that I set the rng object to just the first cell of the Range actually returned by the DataRange.

Group Pivot Table Dates

Now that I have the first cell of the DataRange, I am ready to group the range. Recall, I want to group dates by month. One of the optional parameters of the Group Method is Periods; which is an array of Boolean values that specify the period for the group.


 

Read more on the Group Method of the Range Object here

 


The snippet from the main procedure. Note that I set the 5th element of the Array to “True”. This specifies that the grouping should be by months as per the documentation on MSDN.


'Group pivot table dates
    Periods = Array(False, False, False, False, True, False, False)
    Call GroupRange(rng:=xlPivotTableRange, _
                    varrPeriods:=Periods)

And the Group Range Sub():

Option Explicit

Public Sub GroupRange(rng As Object, _
                      varrPeriods() As Variant)
 
    '=============================================================================
    'Uses the Group Method of the Range Object
    'Only works if Range Object is single cell in PivotTable field’s data range
    'https://msdn.microsoft.com/EN-US/library/office/ff839808.aspx
    'Group(Start, End, By, Periods)
 
    'Array element   Period
    '----------------------
        '1          Seconds
        '2          Minutes
        '3          Hours
        '4          Days
        '5          Months
        '6          Quarters
        '7          Years
 
    '==============================================================================
 
    'Declare objects
        Dim C As Object
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Get first cell of range
        Set C = rng.Cells(1, 1)
 
    'Group range
        C.Group _
            Periods:=varrPeriods()
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Group pivot field data range", Err.HelpFile, Err.HelpContext
 
    'Tidy up
        Set C = Nothing
 
End Sub

GroupDates

The individual dates in the Column Fields have been grouped by month and the groups have been collapsed to display just the average score for each Rep for each month.

Format DataFields

The Pivot Table is looking good, next I would like to format the DataFields to only display to the hundredths:

Public Sub FormatPivotField(pt As Object)
 
    'Declare objects
        Dim pf As Object
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Format datafields
        With pt
            For Each pf In .DataFields
                pf.NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
            Next pf
        End With
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Format DataFields", Err.HelpFile, Err.HelpContext
 
End Sub

PTFormatNumbers

Set The Column Widths

Another way to improve readability of the Pivot Table is to set all columns to a consistent width:

Option Explicit

Public Sub PivotTableRangeColWidth(pt As Object)
 
    'Declare objects
        Dim rng As Object
 
    'Error handler
        On Error GoTo ErrHandler
 
    'Get range oject from pivot table
        Set rng = GetPivotTableRange(pt:=pt, _
                                     strRangeType:="DataBodyRange")
 
    'Set column width
        rng.ColumnWidth = 15
 
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Range Column Width", Err.HelpFile, Err.HelpContext
 
    'Tidy up
        Set rng = Nothing
 
End Sub

PTColumnWidths

There is a lot more I could do to format the final Pivot Table, but this post is already long enough.

The Main Sub()

Here’s the Main Sub() that calls all other Functions() and Subs()

Option Explicit

Private Sub CreateReport()
    
    'Declare objects
        Dim db As DAO.Database
        Dim qdf As DAO.QueryDef
        Dim rs As DAO.Recordset
        Dim xlApplication As Object
        Dim xlWorkbook As Object
        Dim xlWorksheetData As Object
        Dim xlWorksheetReport As Object
        Dim xlRange As Object
        Dim xlListObject As Object
        Dim xlPivotCache As Object
        Dim xlPivotTable As Object
        Dim xlPivotTableRange As Object
 
    'Declare variables
        Dim strQueryName As String
        Dim i As Long
        Dim Periods() As Variant
        
    'Error handler
        On Error GoTo ErrHandler
     
    'Open selected query
        strQueryName = Nz(Me.lstQueries.Value, "")
        If Len(strQueryName) > 0 Then DoCmd.OpenQuery strQueryName
          
    'Close form
        If Me.chkAutoClose.Value = True Then DoCmd.Close acForm, Me.Name
        
    'Get database, query definition and recordset objects
        Set db = CurrentDb
        Set qdf = db.QueryDefs(strQueryName)
        Set rs = qdf.OpenRecordset
        
    'Get Excel Application
        Set xlApplication = GetXlApp()
        xlApplication.Visible = True
    
    'Get Excel Workbook
        Set xlWorkbook = GetXlWorkbook(xlApp:=xlApplication)
        
    'Get Excel Worksheet
        Set xlWorksheetData = xlWorkbook.Worksheets(1)
        xlWorksheetData.Name = "Data"
        
    'Get Excel Range
        Set xlRange = xlWorksheetData.Range("A2")
        
    'Copy the recordset to the Excel Range
        xlRange.CopyFromRecordset rs
        
    'Copy field headers from the recordset to the Excel Worksheet
        For i = 1 To rs.Fields.Count
            xlWorksheetData.Cells(1, i).Value = rs.Fields(i - 1).Name
        Next i
        
    'Add a ListObject Object
        Set xlListObject = GetListObject(ws:=xlWorksheetData)
    
    'Add a Pivot Cache
        Set xlPivotCache = GetPivotCache(wb:=xlWorkbook, _
                                         lo:=xlListObject)
        
    'Add a worksheet for the pivot table
        Set xlWorksheetReport = AddWorksheet(wb:=xlWorkbook, _
                                             strSheetName:="rpt")
                                             
    'Add a pivot table
        Set xlPivotTable = GetPivotTable(pc:=xlPivotCache, _
                                         ws:=xlWorksheetReport, _
                                         strPivotTableName:="PivotTable1")
                                         
    'Add pivot fields to pivot table
        Call AddFieldsToPivot(pt:=xlPivotTable, _
                              strQuery:=strQueryName)
                              
    'Get pivot table range to group
        Set xlPivotTableRange = GetPivotTableRange(pt:=xlPivotTable, _
                                                   strRangeType:="PivotItemDataRange", _
                                                   strPivotField:="TrxDate")
                                                   
    'Group pivot table dates
        Periods = Array(False, False, False, False, True, False, False)
        Call GroupRange(rng:=xlPivotTableRange, _
                        varrPeriods:=Periods)
                        
    'Format pivot table values
        Call FormatPivotField(pt:=xlPivotTable)
        
    'Format pivot table column width
        Call PivotTableRangeColWidth(pt:=xlPivotTable)
        
ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Create Report", Err.HelpFile, Err.HelpContext
        
    'Tidy up
        Set rs = Nothing
        Set qdf = Nothing
        Set db = Nothing
        
        Set xlRange = Nothing
        Set xlPivotTableRange = Nothing
        Set xlListObject = Nothing
        Set xlPivotTable = Nothing
        Set xlPivotCache = Nothing
        Set xlWorksheetData = Nothing
        Set xlWorksheetReport = Nothing
        Set xlWorkbook = Nothing
        Set xlApplication = Nothing

End Sub

Homework

There’s more I could do here, but this post is long enough and I wanted to leave some meat on the bone. Additional items to be added:

  • Additional Pivot Tables
  • Charts and/or Pivot Charts
  • Slicer Cache
  • Slicers
  • Worksheet Display Settings
  • Page Setup Settings For Printing

Downloads

You may download the Access Database and/or the code modules (.bas files) from OneDrive.

  • Push.accdb
  • Form_frmQueryPicker.cls
  • M_Globals.bas
  • M_GroupPivotTableRange.bas
  • M_PushToExcel.bas
  • M_XlAddWorksheet.bas
  • M_XlApp.bas
  • M_XlFormatPivotField.bas
  • M_XlListObjects.bas
  • M_XlPivotCache.bas
  • M_XlPivotFields.bas
  • M_XlPivotTable.bas
  • M_XlPivotTableRange.bas
  • M_XlPivotTableRangeColWidth.bas
  • M_xlWorkbook.bas

OneDrive

Additional Pivot Table Resources – Around The Excel Horn

Some authors of my favorite resources for working with Pivot Tables:

Additional Pivot Table Resources – dataprose.org

Some additional resources for working with Pivot Tables on my blog

Tidy Up

That’s all for today. A very long post – even by my standards. Storing data in a database (even if small and simple as Access) and then working with that data for reporting purposes in Excel makes a lot of sense. Highly recommended!

, , , , , , , , , , , , , , , , , ,

LawnMower_2

Ahhh, mowing the lawn. Going to William’s 66 to buy some fuel. The smell of the gas, the fresh cut grass, fighting the fly-wheel, trying to get perfectly straight lines, rushing to beat the encroaching summer storm, getting a little too close to mom’s peonies – oops!

I traded a mix of Bluegrass, Rye and Fescue of the Midwest a long time ago for the rusty reddish brown that dominates the landscape of the American Southwest. Still, at times, it is great to remember simpler days.

Today’s post, however, is not about how to maintain a 4-Cycle Briggs & Stratton engine. Rather, it is about how to push reporting to Excel.

The Debate

Push to Excel or Pull to Excel? I go back and forth. For me, it depends on my end in mind. If I am completing a corporate model/template – I am more likely to pull data into Excel from other Excel workbooks or various databases. However, if I am creating reports – especially ad hoc – then pushing to Excel might make more sense. Let’s take a look.

Is Excel Running Or Create A New Instance Of Excel

The first thing I want to do, is determine if Excel is running. If Excel is running, use the current instance of Excel, otherwise, create a new instance of Excel.

Option Explicit

Public Function GetXlApp() As Excel.Application

    'Declare objects
        Dim App As Excel.Application

    'Check if Excel is running
        On Error Resume Next
        Set App = GetObject(, "Excel.Application")
        On Error GoTo 0

    'Create Excel if it is not already running
        If App Is Nothing Then
            Set App = CreateObject("Excel.Application")
        End If

    'Pass object to function
        Set GetXlApp = App

    'Tidy up
        Set App = Nothing

End Function

Create Workbook

Now that I have an instance of Excel, I need to add a new Workbook and Worksheet to the instance of Excel

    'Add workbook object
        Set xlBook = xlApp.Workbooks.Add

    'Create worksheet object
        Set xlSheet = xlBook.Worksheets(1)

Excel New Instance

So far, I have created an instance of Excel and added a Workbook and Worksheet to that instance.

Transfer Data From Source To Destination

Now that I have a new instance of Excel and a workbook and worksheet in that instance, I can transfer the data from my source workbook to he new workbook

    'Get rows and columns of region
        With rngCurrent
            rngRows = .Rows.Count
            rngCols = .Columns.Count
        End With

    'Resize destination range
        With xlSheet
            Set xlRange = .Range("A1")
            Set xlRange = xlRange.Resize(rngRows, rngCols)
        End With

    'Transfer range values
        xlRange.Value = rngCurrent.Value

Excel New Instance_2

The data has been transferred from the source workbook to the new workbook. Note how I use rngNew.value = rngOld.value so I do not rely on copy/paste using the Windows Clipboard.

Add A ListObject To The New Range

I’m a huge fan of ListObject Objects (a.k.a. Excel Tables) Are you? Why or why not? Let’s add one to the new workbook to the range of data just transferred.

    'Add a listobject
        Set xlListObject = GetListObject(ws:=xlSheet)

Option Explicit

Public Function GetListObject(ws As Worksheet)

    'Declare objects
        Dim rng As Range
        Dim C As Range
        Dim lo As ListObject

    'Error handler
        On Error GoTo ErrHandler

    'Create range object
        Set rng = ws.UsedRange
        Set C = rng.Cells(1, 1)

    'Add listobject
        Set lo = ws.ListObjects.Add( _
                        SourceType:=xlSrcRange, _
                        Source:=rng, _
                        Destination:=C)

    'Pass the object to the function
        Set GetListObject = lo

ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get ListObject", Err.HelpFile, Err.HelpContext

    'Tidy up
        Set lo = Nothing
        Set C = Nothing
        Set rng = Nothing

End Function

Excel New Instance_3
A ListObject Object (Excel Table) has been added, I chose to place it exactly where the Range existed previously, I could have put it anywhere. However, since the Range Object and the ListObject Object contain the same data, why keep both? I now have a ListObject which will automatically expand in case someone decides to add additional information after the data was pushed from an external data source.

Add a Pivot Cache

To add a Pivot Table, I need a Pivot Cache. I’ll use the Excel Table as the data source for the Pivot Cache.

    'Add a pivot cache
        Set xlPivotCache = GetPivotCache(wb:=xlBook, _
                                         lo:=xlListObject)

Public Function GetPivotCache(wb As Workbook, _
                              lo As ListObject)

    'Declare Objects
        Dim pc As PivotCache

    'Declare variables
        Dim strPivotCacheSource As String

    'Error handler
        On Error GoTo ErrHandler

    'Pivot cache source
        strPivotCacheSource = lo.Parent.Name & "!" & _
                                lo.Range.Address(ReferenceStyle:=xlR1C1)

    'Create pivot cache
        Set pc = wb.PivotCaches.Create( _
                        SourceType:=xlDatabase, _
                        SourceData:=strPivotCacheSource)

    'Pass object to function
        Set GetPivotCache = pc

ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get pivot cache", Err.HelpFile, Err.HelpContext

    'Tidy up
        Set pc = Nothing

End Function

Add A Worksheet For The Pivot Table Report

Now that I have a Pivot Cache, I need to add a Worksheet for the Pivot Table Report

    'Add a sheet for the pivot table
        Set xlSheetReport = AddWorksheet(wb:=xlBook, _
                                         strSheetName:="rpt")

Public Function AddWorksheet(wb As Workbook, _
                             strSheetName As String) As Worksheet

    'Declare variables
        Dim ws As Worksheet
        Dim strMySheetName As String

    'Error handler
        On Error GoTo ErrHandler

    'Add worksheet
        With wb
            Set ws = .Sheets.Add(After:=.Sheets(wb.Sheets.Count))
            ws.Name = strSheetName
        End With

    'Pass object to function
        Set AddWorksheet = ws

ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Add a worksheet", Err.HelpFile, Err.HelpContext

    'Tidy up
        Set ws = Nothing

End Function

Excel New Instance_4
I now have a new Worksheet to hold the Pivot Table.

Add a Pivot Table

Now that I have a new Worksheet, I can add a Pivot Table

    'Add a pivot table
        Set xlPivotTable = GetPivotTable(pc:=xlPivotCache, _
                                         ws:=xlSheetReport, _
                                         strPivotTableName:="PivotTable1")

Public Function GetPivotTable(pc As PivotCache, _
                              ws As Worksheet, _
                              strPivotTableName As String, _
                              Optional ByVal lngRowPlacement As Long = 3, _
                              Optional ByVal lngColPlacement As Long = 3)

    'Declare Objects
        Dim pt As PivotTable
        Dim rng As Range

    'Declare variables
        Dim strPivotPlacement As String

    'Error handler
        On Error GoTo ErrHandler

    'Create range
        Set rng = ws.Cells(lngRowPlacement, lngColPlacement)

    'Pivot table placement
        strPivotPlacement = ws.Name & "!" & _
                            rng.Address(ReferenceStyle:=xlR1C1)

    'Create pivot table
        Set pt = pc.CreatePivotTable( _
                    TableDestination:=strPivotPlacement, _
                    TableName:=strPivotTableName)

    'Pass object to function
        Set GetPivotTable = pt

ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get pivot table", Err.HelpFile, Err.HelpContext

    'Tidy up
        Set rng = Nothing
        Set pt = Nothing

End Function

Excel New Instance_5
Now that I have a Pivot Table, I can add Pivot Fields.

Add Pivot Fields To Pivot Table

Now that I have a Pivot Table, I need to specify which fields to use from the Excel Table and their Orientation and Order in the Pivot Table:

Private Sub AddFieldsToPivot(pt As PivotTable)

    'Error handler
        On Error GoTo ErrHandler

    'Add fields to pivot table
        With pt

            'Row fields
                .PivotFields("Region").Orientation = xlRowField
                .PivotFields("Region").Position = 1

                .PivotFields("Reps").Orientation = xlRowField
                .PivotFields("Reps").Position = 2

            'Column fields
                .PivotFields("TrxDate").Orientation = xlColumnField
                .PivotFields("TrxDate").Position = 1

            'Value fields
                .AddDataField .PivotFields("Score"), _
                    Caption:="Avgerage of Score", _
                    Function:=xlAverage
        End With

ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get pivot table fields", Err.HelpFile, Err.HelpContext

End Sub

Excel New Instance_7

Group Dates By Month

Notice that the Pivot Table currently displays each day in a Column Field. I would prefer to group the dates based on the month. I can achieve this by using the Group Method of the Range Object. So first I will need to find the Range to group.

Get A Range From A Pivot Table

I need to get the first Cell in the PivotField “TrxDate” DataRange, so I’ll use the Pivot Item DataRange.


 

Read more on various ranges within a pivot table and their special VBA range names on Jon Peltier’s site

 


 

    'Get pivot table range to group
        Set xlPivotTableRange = GetPivotTableRange(pt:=xlPivotTable, _
                                                   strRangeType:="PivotItemDataRange", _
                                                   strPivotField:="TrxDate")

Public Function GetPivotTableRange(pt As PivotTable, _
                                   strRangeType As String, _
                                   Optional ByVal strPivotField As String = vbNullString) As Range

    'Pivot field Range type documentation:
    'http://peltiertech.com/referencing-pivot-table-ranges-in-vba/                  <-Jon Peltier

    'String range types:
        'PivotItemDataRange

    'Declare objects
        Dim rng As Range

    'Error handler
        On Error GoTo ErrHandler

    'Create pivot table range
        Select Case strRangeType
            Case "PivotItemDataRange"
                Set rng = pt.PivotFields(strPivotField).DataRange.Cells(1, 1)
            Case Else
                MsgBox "That is not an option"
                Exit Function
        End Select

    'Pass object to function
        Set GetPivotTableRange = rng

ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get pivot table range", Err.HelpFile, Err.HelpContext

    'Tidy up
        Set rng = Nothing

End Function

Note that I set the rng object to just the first cell of the Range actually returned by the DataRange. Also, note that the Select Case statement is only the beginning of the function that handles one simple case of a special VBA range name. I will revisit this function later and update it with all of the special VBA range names of a Pivot Table as Jon documents on his site.

Group Pivot Table Dates

Now that I have the first cell of the DataRange, I am ready to group the range. Recall, I want to group dates by month. One of the optional parameters of the Group Method is Periods; which is an array of Boolean values that specify the period for the group.


 

Read more on the Group Method of the Range Object here

 


 

    'Group pivot table dates
        Periods = Array(False, False, False, False, True, False, False)
        Call GroupRange(rng:=xlPivotTableRange, _
                        varrPeriods:=Periods)

Note that I set the 5th element of the Array to “True”. This specifies that the grouping should be by months as per the documentation on MSDN. Here is the Sub() that I am calling:

Public Sub GroupRange(rng As Range, _
                      varrPeriods() As Variant)

    '=============================================================================
    'Uses the Group Method of the Range Object
    'Only works if Range Object is single cell in PivotTable field’s data range
    'https://msdn.microsoft.com/EN-US/library/office/ff839808.aspx
    'Group(Start, End, By, Periods)

    'Array element   Period
    '----------------------
        '1          Seconds
        '2          Minutes
        '3          Hours
        '4          Days
        '5          Months
        '6          Quarters
        '7          Years

    '==============================================================================

    'Declare objects
        Dim C As Range

    'Error handler
        On Error GoTo ErrHandler

    'Get first cell of range
        Set C = rng.Cells(1, 1)

    'Group range
        C.Group _
            Periods:=varrPeriods()

ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Group pivot field data range", Err.HelpFile, Err.HelpContext

    'Tidy up
        Set C = Nothing

End Sub

Excel New Instance_8

The individual dates in the Column Fields have been grouped by month and the groups have been collapsed to display just the average score for each Rep for each month.

Format DataFields

The Pivot Table is looking good, next I would like to format the DataFields to only display to the hundredths:

Private Sub FormatPivotField(pt As PivotTable)

    'Declare objects
        Dim pf As PivotField

    'Error handler
        On Error GoTo ErrHandler

    'Format datafields
        With pt
            For Each pf In .DataFields
                pf.NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
            Next pf
        End With

ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Format DataFields", Err.HelpFile, Err.HelpContext

End Sub

Excel New Instance_9_DataField Format
That looks better.

Set The Column Widths

Another way to improve readability of the Pivot Table is to set all columns to a consistent width. I can set the ColumnWidth of a Range Object, so I’ll use the Function I created earlier to get a special VBA range from the Pivot Table. This time I want to use the DataBodyRange, so first I’ll modify my function to add the new Range Type. Here if the modified function:

Public Function GetPivotTableRange(pt As PivotTable, _
                                   strRangeType As String, _
                                   Optional ByVal strPivotField As String = vbNullString) As Range

    'Pivot field Range type documentation:
    'http://peltiertech.com/referencing-pivot-table-ranges-in-vba/                  <-Jon Peltier

    'String range types:
        'PivotItemDataRange
        'DataBodyRange

    'Declare objects
        Dim rng As Range

    'Error handler
        On Error GoTo ErrHandler

    'Create pivot table range
        Select Case strRangeType
            Case "PivotItemDataRange"
                Set rng = pt.PivotFields(strPivotField).DataRange.Cells(1, 1)
            Case "DataBodyRange"
                Set rng = pt.DataBodyRange
            Case Else
                MsgBox "That is not an option"
                Exit Function
        End Select

    'Pass object to function
        Set GetPivotTableRange = rng

ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Get pivot table range", Err.HelpFile, Err.HelpContext

    'Tidy up
        Set rng = Nothing

End Function

And here is the Sub{} that calls the function to set the column width:

Public Sub PivotTableRangeColWidth(pt As PivotTable)

    'Declare objects
        Dim rng As Range

    'Error handler
        On Error GoTo ErrHandler

    'Get range oject from pivot table
        Set rng = GetPivotTableRange(pt:=pt, _
                                     strRangeType:="DataBodyRange")

    'Set column width
        rng.ColumnWidth = 15

ErrHandler:
    If Err.Number > 0 Then _
        MsgBox Err.Description, vbMsgBoxHelpButton, "Range Column Width", Err.HelpFile, Err.HelpContext

    'Tidy up
        Set rng = Nothing

End Sub

And the Pivot Table with the DataBodyRange set to a ColumnWidth of 15

Excel New Instance_10_ColumnWidth

There is a lot more I could do to format the final Pivot Table, but this post is already long enough.

The Main Sub()

Here’s the Main Sub() that calls all other Functions() and Subs()

Option Explicit
Sub PushToExcel()

    'Declare objects
        Dim wbCurrent As Workbook
        Dim wsCurrent As Worksheet
        Dim rngCurrent As Range
        Dim rng As Range
        Dim xlPivotTableRange As Range
        Dim xlRange As Range
        Dim xlApp As Object
        Dim xlBook As Object
        Dim xlSheet As Object
        Dim xlSheetReport As Object
        Dim xlListObject As Object
        Dim xlPivotCache As Object
        Dim xlPivotTable As Object

    'Declare variables
        Dim rngRows As Long
        Dim rngCols As Long
        Dim Periods() As Variant

    'Current objects
        Set wbCurrent = ActiveWorkbook
        Set wsCurrent = wbCurrent.ActiveSheet
        Set rngCurrent = wsCurrent.UsedRange

    'Get Excel app
        On Error Resume Next
        Set xlApp = GetXlApp
        If Not xlApp Is Nothing Then
            xlApp.Visible = True
        Else
            MsgBox "The application was not created. Exiting."
            Exit Sub
        End If

    'Add workbook
        Set xlBook = xlApp.Workbooks.Add

    'Create worksheet object
        Set xlSheet = xlBook.Worksheets(1)

    'Get rows and columns of region
        With rngCurrent
            rngRows = .Rows.Count
            rngCols = .Columns.Count
        End With

    'Resize destination range
        With xlSheet
            Set xlRange = .Range("A1")
            Set xlRange = xlRange.Resize(rngRows, rngCols)
        End With

    'Transfer range values
        xlRange.Value = rngCurrent.Value

    'Add a listobject
        Set xlListObject = GetListObject(ws:=xlSheet)

    'Add a pivot cache
        Set xlPivotCache = GetPivotCache(wb:=xlBook, _
                                         lo:=xlListObject)

    'Add a sheet for the pivot table
        Set xlSheetReport = AddWorksheet(wb:=xlBook, _
                                         strSheetName:="rpt")

    'Add a pivot table
        Set xlPivotTable = GetPivotTable(pc:=xlPivotCache, _
                                         ws:=xlSheetReport, _
                                         strPivotTableName:="PivotTable1")

    'Add fields to pivot table
        Call AddFieldsToPivot(pt:=xlPivotTable)

    'Get pivot table range to group
        Set xlPivotTableRange = GetPivotTableRange(pt:=xlPivotTable, _
                                                   strRangeType:="PivotItemDataRange", _
                                                   strPivotField:="TrxDate")

    'Group pivot table dates
        Periods = Array(False, False, False, False, True, False, False)
        Call GroupRange(rng:=xlPivotTableRange, _
                        varrPeriods:=Periods)

    'Format pivot table
        Call FormatPivotField(pt:=xlPivotTable)

    'Set column width pivot table data body
        Call PivotTableRangeColWidth(pt:=xlPivotTable)

    'Tidy up
        'Destroy objects
            Set rngCurrent = Nothing
            Set xlRange = Nothing
            Set xlPivotTableRange = Nothing
            Set xlListObject = Nothing
            Set xlPivotCache = Nothing
            Set xlPivotTable = Nothing
            Set wsCurrent = Nothing
            Set xlSheet = Nothing
            Set xlSheetReport = Nothing
            Set xlBook = Nothing
            Set wbCurrent = Nothing
            Set xlApp = Nothing

End Sub

Homework

There’s more I could do here, but this post is long enough and I wanted to leave some meat on the bone. Additional items to be added:

  • Additional Pivot Tables
  • Charts and/or Pivot Charts
  • Slicer Cache
  • Slicers
  • Worksheet Display Settings
  • Page Setup Settings For Printing

Downloads

You may download the workbook and/or the code modules (.bas files) from OneDrive.

  • PushToExcel_20150516_v1.xlsm
  • M_PushToExcel.bas
  • M_Worksheet.bas
  • M_Public.bas
  • M_Pivot.bas
  • M_ListObjects.bas

Excel New Instance_11_Downloads

Additional Pivot Table Resources – Around The Excel Horn

Some authors of my favorite resources for working with Pivot Tables:

Additional Pivot Table Resources – dataprose.org

Some additional resources for working with Pivot Tables on my blog

, , , , , , , , ,

BearFF

In my last post on using ActiveX Data Objects (ADO) with Excel VBA, I demonstrated some code to load a Recordset, filter the Recordset using the Recordset’s Filter Prpoerty, and copy the Filtered Recordset to a Worksheet using the CopyFromRecordset Method of the Range Object.

I put a link to the blog post on the Excel VBA and Users Group on LinkedIn. To our good fortune, James Wilson was reading. James responded with some nice comments and some very good code of his own. I was impressed and asked James if he would like to do a write up to post on the blog.

James kindly accepted my offer as follows in James’ words. Take it away James!



Bringing the full power of SQL to bear in Excel

James Wilson
September 13, 2014

“I feel the need, the need for speed.” Top Gun

I love Excel, but sometimes you just want a bit more power to analyse your data. My favourite tool for analysing large quantities of data has always been SQL. While Microsoft includes MS Query in Excel out-of-the-box, it does have many limitations and is relatively slow. Using VBA and ADO is the next logical step.

The code below is the latest incarnation of a general purpose SQL function I’ve been using for the last five years or so. For me the data is the thing – I want to be able to start querying my data using SQL without having to start coding from scratch each time. Just copy and paste into a module in your workbook, and you’re ready to go.

Code first then some explanation:

Function SQL(ByVal SQLstr As String, ByVal Destination As String, Optional ByVal ConnectionString As String) As Boolean

    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False

    Dim myConnection As Object
    Dim myRecordSet As Object
    Dim myQueryTable As QueryTable

    ThisWorkbook.Sheets(Destination).Activate
    ThisWorkbook.Sheets(Destination).Cells.Delete

    If ConnectionString = "" Then ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 12.0"
    
    Set myConnection = CreateObject("ADODB.Connection")
    Set myRecordSet = CreateObject("ADODB.Recordset")
    
    myConnection.ConnectionString = ConnectionString
    myConnection.Open
    myRecordSet.ActiveConnection = ConnectionString
    myRecordSet.Source = SQLstr
    myRecordSet.Open
    
    Set myQueryTable = Sheets(Destination).QueryTables.Add(Connection:=myRecordSet, Destination:=Range("'" & Destination & "'!a1"))
    myQueryTable.Refresh
    
    If myRecordSet.State <> adStateClosed Then myRecordSet.Close
    If Not myRecordSet Is Nothing Then Set myRecordSet = Nothing
    If Not myConnection Is Nothing Then Set myConnection = Nothing
    
    Err.Clear
ErrorHandler:
    If Err Then
        Sheets(Destination).Cells(1, 1) = "SQL Error: " & Err.Description
        SQL = False
    Else
        SQL = True
    End If
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
End Function

I wrote this as a VBA function rather than a sub procedure, because I wanted to be able to trap errors in the calling procedure. It is a really a matter of preference whether you like your functions to return True or False (lines 28 and 30). I’ve chosen to return True if it worked, so I’d call it using coding something like:

Sub test()
    DidItWork = SQL("SELECT * FROM [Sheet1$] WHERE [Sheet1$].[date] > #01/03/2014#", "Sheet2")
    If DidItWork = False Then … 'Do some error handling
End Sub

Basically this function sets up an ADO link to a data source, executes an SQL query on that data, and returns the results of that query to a worksheet of our choice in the current workbook using a query table.

When you call this function (line 1), you pass a string with your SQL query, a string with the name of the worksheet you want the data to be returned to, and optionally a connection string to the data source. By default the data source is the workbook the code is in. That’s right – you can use SQL to query data in other tabs in the same workbook (make sure your workbook is saved first).

If you find that most of the time you are querying a corporate database or other data source, then you’d just tweak line 15 of the coding to default to the connection string to the data source you are using most often.

Lines 4 to 6 and 42 to 44 are just the standard VBA codes that you’d put in to speed up any bit of coding. If you are calling this function and have these bits of coding in the calling procedure, then you can safely delete these lines from this function.

Lines 8 to 10 are to set up a local connection and recordset object (we’re going to use ADO to get our data), and a query table (which we are going to use to return the results of the SQL query to Excel).

The way this function is written, your data output is always going to be a worksheet in the current workbook in Cell A1. You can have no other data in this worksheet as Lines 12 to 13 delete the contents of the worksheet, before it is refreshed again with the query table set up in Line 26.

Line 17 to 27 is the meat of the function, setting up an ADO link and returning the data using a query table.

Lines 29 to 31 are to tidy up objects and connections. Line 36 is to give you a clue if you’ve made an error in your SQL.

So I’ve a personal library function that allows me to use SQL in Excel without much further thought – what do I do with it? Let me give a few simple examples to give an idea of the possibilities.

  1. Treat my current spreadsheet a bit like a mini-database and run queries on it – that would be much harder to do just using VBA or manually copying and pasting.
  2. Suck data out of multiple corporate databases and spreadsheets and join it together. You don’t need even to open the spreadsheets to get the data (as I said to start with – it’s all about speed and power). So for example let’s say you have one spreadsheet from your sales guys with sales volumes, and you have another spreadsheet with the confidential prices for each customer, then you can do a bit of SQL coding like:
    DidItWork = SQL(“SELECT A.*, B.[Price], A.[Volume]*B.[Price] as [Revenue] from [C:\Sales Volumes.xlsx].[Data$] A LEFT OUTER JOIN [F:\Prices.xlsx].[Sheet1$] B ON A.[Product] = B.[Product] AND A.[Customer No] = B.[Customer] “, “Sales Forecast”)
    So I’m using SQL aliases A and B for brevity, and by using multipart identifiers specifying the full path and filename of the Excel workbooks I can suck data out of any file I have access to. Note if you specify the data source fully, the connection string ADO uses is virtually irrelevant.
  3. By using For…Next loops in VBA and a bit of text manipulation and the SQL command UNION I can consolidate multiple similar data sources simply. So using a string variable like below in a loop:

mySQLstring = mySQLstring & ” UNION ” & …
Good for consolidating budgets submitted in a similar format.

The limitation is really your knowledge of SQL. Beware of missing spaces and extra commas in your SQL if you are using the VBA & _ to join long strings together to form your SQL.


Tidy Up

Thanks James – great job! How do you use ADO, SQL, Recordsets and QueryTables in your Projects?

, , , , , , , , ,

FemmesFinal

I hope you know that this will go down on your permanent record
Oh yeah? Well, don’t get so distressed
Did I happen to mention that I’m impressed?

So go the lyrics from Kiss Off by the Violent Femmes pictured here. Great song from the 80’s. If you are not familiar with the Femmes, check ’em out – highly recommended.

However, today’s post is not about the Alternative Rock scene of the early 80’s. Rather, it is about ActiveX Data Objects (ADO) Recordsets.


    edit: As is my usual practice, I am going to use Late Binding in the sample snippets below. A discussion on Late / Early Binding is beyond the scope of this post. Please see these links for a detailed explanation of Late / Early Binding.

    1. Beyond Excel
    2. JP Software Technologies


Global Constants

Because I am using Late Binding, I am going to setup Global Constants for the various Enumerations I need for Command Types, Cursor Locations, Cursor Types and Lock Types. It takes a little bit of extra work, but I think it makes the code clearer:

Clear:

cmd.CommandType = gcladCmdText

Not clear:

cmd.CommandType = 1

See? The Constant is self-documenting and makes the code clearer.

Here’s all the Global Contants. I put them in a Module named “M_Globals” because I’m creative that way.

'Command Type Enumeration Values
    Public Const gcladCmdUnspecified = -1       'Unspecified type of command
    Public Const gcladCmdText = 1               'Evaluates CommandText as a textual definition of a command or stored procedure call
    Public Const gcladCmdTable = 2              'Evaluates CommandText as a table name whose columns are returned by an SQL query
    Public Const gcladCmdStoredProc = 4         'Evaluates CommandText as a stored procedure name
    Public Const gcladCmdUnknown = 8            'Default. Unknown type of command
    Public Const gcladCmdFile = 256             'Evaluates CommandText as the file name of a persistently stored Recordset. Used with Recordset.Open or Requery only.
    Public Const gcladCmdTableDirect = 512      'Evaluates CommandText as a table name whose columns are all returned. Used with Recordset.Open or Requery only. To use the Seek method, the Recordset must be opened with adCmdTableDirect. Cannot be combined with the ExecuteOptionEnum value adAsyncExecute.

'Cursor Location Enumeration Values
    Public Const gcladUseNone = 1               'OBSOLETE (appears only for backward compatibility). Does not use cursor services
    Public Const gcladUseServer = 2             'Default. Uses a server-side cursor
    Public Const gcladUseClient = 3             'Uses a client-side cursor supplied by a local cursor library. For backward compatibility, the synonym adUseClientBatch is also supported
    
'Cursor Type Enumeration Values
    Public Const gcladOpenUnspecified = -1      'Unspecified type of cursor
    Public Const gcladOpenForwardOnly = 0       'Default. A forward-only cursor. This improves performance when you need to make only one pass through a Recordset
    Public Const gcladOpenKeyset = 1            'A keyset cursor. Like a dynamic cursor, except that you can't see records that other users add, although records that other users delete are inaccessible from your Recordset. Data changes by other users are still visible.
    Public Const gcladOpenDynamic = 2           'A dynamic cursor. Additions, changes, and deletions by other users are visible, and all types of movement through the Recordset are allowed
    Public Const gcladOpenStatic = 3            'A static cursor. A static copy of a set of records that you can use to find data or generate reports. Additions, changes, or deletions by other users are not visible.

'Lock Type Enumeration Values
    Public Const gcladLockUnspecified = -1      'Unspecified type of lock. Clones inherits lock type from the original Recordset.
    Public Const gcladLockReadOnly = 1          'Default. Read-only records
    Public Const gcladLockPessimistic = 2       'Pessimistic locking, record by record. The provider lock records immediately after editing
    Public Const gcladLockOptimistic = 3        'Optimistic locking, record by record. The provider lock records only when calling update
    Public Const gcladLockBatchOptimistic = 4   'Optimistic batch updates. Required for batch update mode

Let The User Choose Which Worksheet To Load To The Recordset

In the function below, I use an InputBox Type:=8 to let the user choose a cell on the worksheet that contains the data that should be loaded into the recordset:

Public Function GetSelectedSheet(strPrompt As String, _
                                 strTitle As String) As String
     
    'Declare variables
        Dim ws                          As Worksheet
        Dim rng                         As Range
     
    'Users - select a cell on a worksheet
        Set rng = Application.InputBox( _
                                       Prompt:=strPrompt, _
                                       Title:=strTitle, _
                                       Default:=ActiveCell.Address, _
                                       Type:=8) 'Range selection
                     
    'Get the parent worksheet of the selected cell
        Set ws = rng.Parent
         
    'Pass the name of the worksheet to the function
        GetSelectedSheet = ws.Name
     
    'Tidy up
        Set rng = Nothing
        Set ws = Nothing
 End Function

And I call the function like this:

        'Get worksheet to be loaded into recordset
            strWorksheet = GetSelectedSheet(strPrompt:="Select a cell on the worksheet to be loaded into the recordset", _
                                            strTitle:="Worksheet To Recordset")

Save The Data To A New Workbook

I could not get the ADO code to work with data in the same workbook, so in the end I decided to just save the data the user selected out to a new workbook:

First, I added a workbook:

        'Create a new workbook to hold all data from the selected worksheet
            Set wbADO = Workbooks.Add

Then I sent the original workbook, the new workbook and the the worksheet that the user selected to a Private Sub to handle the copying:

Call the sub:

        'Copy everything from the selected worksheet to the new workbook
            Call CopyData(wbSource:=wb, _
                          wbDestination:=wbADO, _
                          strSource:=strWorksheet)

The Sub() to copy the entire worksheet from one workbook to another:

Private Sub CopyData(wbSource As Workbook, _
                     wbDestination As Workbook, _
                     strSource As String)
                     
    wbSource.Worksheets(strSource).Copy wbDestination.Worksheets(1)

End Sub

And then the cleanup:

        'Cleanup the destination workbook
            Call CleanupWorkbook(wb:=wbADO)

The Sub() to handle any cleanup chores:

Private Sub CleanupWorkbook(wb As Workbook)

    'Declare variables
        Dim i As Long
        
    'Rename worksheets
    'Delete unneeded worksheets
        With wb
            .Worksheets(1).Name = "Data"
            For i = .Sheets.Count To 2 Step -1
                .Sheets(i).Delete
            Next i
        End With

End Sub

Lastly, I saved and closed the new workbook, since the ADO Process will want to open the workbook

        'Save and close the data workbook
            With wbADO
                .SaveAs wb.Path & "\" & Mid(wb.Name, 1, Len(wb.Name) - 5) & "_ADO.xlsx", FileFormat:=xlOpenXMLWorkbook
                strWorkbookADO = wbADO.FullName
                .Close
            End With

Create A Range Object To Measure Inputs

I would like to measure the amount of rows and columns in the input Range so that after I load the Recordset I can compare the the Range Dimensions to the Recordset Dimensions.

        'Create a range object to measure source data against final recordset data
            Set ws = wb.Worksheets(strWorksheet)
            Set rng = ws.Range("A1").CurrentRegion

SQL String

I like to create a SQL string and then pass the SQL string to the CommandText Property of the Command Object. I think this makes troubleshooting and tuning the SQL easier:

        'SQL string
            strSQL = "SELECT * FROM [Data$]"

Create The ADO Connection Object

I like to encapsulate any objects I am creating. Here is the function to create the ADO Connection Object:

Public Function GetADOConnection() As Object

    Set GetADOConnection = CreateObject("ADODB.Connection")
  
End Function

And here is how I call it:

        'Create ADO Connection Object
            Set cn = GetADOConnection()

ADO Connection Strings

ADO Connection Strings can be a little challenging, luckily, we have ConnectionStrings.com to help us out. Link is at the bottom of the post. I am using Office 2013 with a workbook in xlOpenXMLWorkbook format (.xlsx). So this is the connection string I’ll be using:

cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;" & _
         "Data Source=" & strWorkbookADO & ";" & _
         "Extended Properties='Excel 12.0 Xml;HDR=YES;IMEX=1'")

Create The ADO Command Object

Next, I’ll create the ADO Command Object and set some of the properties of the object. Note here that I am using one of the Global Contants that I declared earlier. I also pass my SQL string here:

        'Create ADO Command Object
            Set cmd = GetCommand()
            Set cmd.ActiveConnection = cn
            cmd.CommandType = gcladCmdText
            cmd.CommandText = strSQL                        'Pass SQL String to the command object

And here is the function to create the Command Object :

Public Function GetCommand() As Object

    Set GetCommand = CreateObject("ADODB.Command")
  
End Function

Create And Load The ADO Recordset

Next I need to create and load the recordset.

'Create ADO Recordset Object and load records
            Set rs = GetRecordset()
            With rs
                .CursorLocation = gcladUseClient
                .CursorType = gcladOpenDynamic
                .LockType = gcladLockOptimistic
                .Open cmd
            End With

And here is the encapsulated function that creates the ADO Recordset Object:

Public Function GetRecordset() As Object

    Set GetRecordset = CreateObject("ADODB.Recordset")
  
End Function

Check Recordset Results Against Expected Results

Lastly, I want to compare the Recordset results against expected results. Do do this I will count the number of records and fields in the Recordset and compare them against the number of rows and columns in the Range Object I created earlier:

        'Compare recordset results to original data
            Debug.Print "The recordset contains " & Format(rs.RecordCount, "##,##0") & " records and " & rs.Fields.Count & " fields"
            Debug.Print "The range contains " & Format(rng.Rows.Count - 1, "##,##0") & " rows and " & rng.Columns.Count & " columns" '-1 to discount header row

Returns:

The recordset contains 60,398 records and 23 fields
The range contains 60,398 rows and 23 columns

Everything is working as it should.

The Main Procedure

Sub PopulateRecordset()

    'Declare variables
        Dim wb As Workbook
        Dim wbADO As Workbook
        Dim ws As Worksheet
        Dim rng As Range
        Dim cn As Object
        Dim rs As Object
        Dim cmd As Object
        Dim strWorksheet As String
        Dim strSQL As String
        Dim strWorkbookADO As String
                
    'Excel environemnt
        With Application
            .ScreenUpdating = False
            .DisplayAlerts = False
            .EnableEvents = False
            .Calculation = xlCalculationManual
        End With

    'Initialize
        Set wb = ThisWorkbook
        
        'Get worksheet to be loaded into recordset
            strWorksheet = GetSelectedSheet(strPrompt:="Select a cell on the worksheet to be loaded into the recordset", _
                                            strTitle:="Worksheet To Recordset")
                                            
        'Create a new workbook to hold all data from the selected worksheet
            Set wbADO = Workbooks.Add
            
        'Copy everything from the selected worksheet to the new workbook
            Call CopyData(wbSource:=wb, _
                          wbDestination:=wbADO, _
                          strSource:=strWorksheet)
                          
        'Cleanup the destination workbook
            Call CleanupWorkbook(wb:=wbADO)
            
        'Save and close the data workbook
            With wbADO
                .SaveAs wb.Path & "\" & Mid(wb.Name, 1, Len(wb.Name) - 5) & "_ADO.xlsx", FileFormat:=xlOpenXMLWorkbook
                strWorkbookADO = wbADO.FullName
                .Close
            End With

        'Create a range object to measure source data against final recordset data
            Set ws = wb.Worksheets(strWorksheet)
            Set rng = ws.Range("A1").CurrentRegion

        'SQL string
            strSQL = "SELECT * FROM [Data$]"

        'Create ADO Connection Object
            Set cn = GetADOConnection()
            cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;" & _
                     "Data Source=" & strWorkbookADO & ";" & _
                     "Extended Properties='Excel 12.0 Xml;HDR=YES;IMEX=1'")

        'Create ADO Command Object
            Set cmd = GetCommand()
            Set cmd.ActiveConnection = cn
            cmd.CommandType = gcladCmdText
            cmd.CommandText = strSQL                        'Pass SQL String to the command object


        'Create ADO Recordset Object and load records
            Set rs = GetRecordset()
            With rs
                .CursorLocation = gcladUseClient
                .CursorType = gcladOpenDynamic
                .LockType = gcladLockOptimistic
                .Open cmd
            End With

        'Compare recordset results to original data
            Debug.Print "The recordset contains " & Format(rs.RecordCount, "##,##0") & " records and " & rs.Fields.Count & " fields"
            Debug.Print "The range contains " & Format(rng.Rows.Count - 1, "##,##0") & " rows and " & rng.Columns.Count & " columns" '-1 to discount header row
            
        'Tidy up
            'Close objects
                rs.Close
                cn.Close
                
            'Destroy objects
                Set rs = Nothing
                Set cmd = Nothing
                Set cn = Nothing
                Set rng = Nothing
                Set ws = Nothing
                Set wbADO = Nothing
                Set wb = Nothing
                
            'Excel environemnt
                With Application
                    .ScreenUpdating = True
                    .DisplayAlerts = True
                    .EnableEvents = True
                    .Calculation = xlCalculationAutomatic
                End With
                    
End Sub

Tidy up

Additional Resources

Downloads

Credits

    Data courtesy Microsoft Excel 2013 Building Data Models with PowerPivot by Alberto Ferrari and Marco Russo (Mar 25, 2013)

Final Thoughts

    I could not get the ADO to work with data in the same workbook that contains the code. That does not mean you cannot – I don’t know. I would generally invoke a FileDialogFilePicker function to select a file that contains the data for processing. That’s it for today. I’ll come back later with more stuff on working with Recordsets. Thanks, Dennis!
, , ,

AdvanceFinal500

AAAAAARRRRGGGGHHHHH!!!!! I just hate reviewing an Excel Workbook with lots of tabs and the ActiveCell is different on every tab. Let’s look at some ways to fix this. Before I can get going, I need to:

  1. Add several copies of a worksheet to the active workbook
  2. Randomize the ActiveCell on each worksheet



    edit: While my main point of this post is the GoTo Method of the Excel Application Object, I touch on many other items as well

  1. Copy Method of the Worksheet Object
  2. Cells Property of the Range Object
  3. Cells Property of the Worksheet Object
  4. Find Method of the Range Object
  5. Range Property of the Worksheet Object
  6. Select..Case Statement
  7. Application Worksheet Function Randbetween
  8. InputBox Method of the Excel Application Object
  9. VBA Instr() Function


Add Worksheet Copies

I downloaded a sample P&L Statement from the Internet. Now I just want to add 29 copies of the P&L Statement to the workbook.

PLStatement

Option Explicit

Sub Foo()

    'Declare variables
        Dim wb As Workbook
        Dim wsPL As Worksheet
    
    'Excel environment
        With Application
            .ScreenUpdating = False
        End With
        
    'Initialize
        Set wb = ThisWorkbook
        Set wsPL = wb.Worksheets("PL_CC")
    
    'Add worksheets
        Call CopyWorksheets(wb:=wb, _
                            wsSource:=wsPL, _
                            NumberOfCopies:=30)

    'Tidy up
        'Destroy objects
            Set wsPL = Nothing
            Set wb = Nothing
            
        'Excel environment
            With Application
                .ScreenUpdating = True
            End With
        
End Sub

Private Sub CopyWorksheets(wb As Workbook, _
                           wsSource As Worksheet, _
                           NumberOfCopies As Long)
    
    'Declare variables
        Dim i As Long
                           
                                   
    'Make copies of worksheet
        For i = 2 To NumberOfCopies
            wsSource.Copy _
                After:=wb.Worksheets(Worksheets.Count)
                ActiveSheet.Name = wsSource.Name & i
        Next i
End Sub

Great! Added 29 copies of the P&L Statement and renamed each worksheet.

PLStatementsMult

Randomize The ActiveCell

Since I made copies of a worksheet the ActiveCell is the same on every worksheet. I want to randomize the ActiveCell before I create some code to set the ActiveCell on every worksheet. The P&L Statement I am using has 15 Columns and 77 Rows. But I would like to determine those values with some VBA so that my code is more dynamic and will wok with any worksheet that I use in the future.

First I’ll check the UsedRange

Private Sub GetUsedRange(ws As Worksheet)

    'Declare variables
        Dim rng As Range
        
    'Create range object
        Set rng = ws.UsedRange
        
    'Print adddress
        Debug.Print rng.Address
        
    'Tidy up
        Set rng = Nothing
  
End Sub

Returns:

$A$1:$Y$77

That’s not what I want. I’m looking for $O$77 as the last used cell.

Last Used Cell Function

This function returns the correct last used cell:

Private Function GetLastUsedCell(ws As Worksheet) As Range

    'Declare variables
        Dim rngLastUsedCell As Range
        
    'Create range object from last used cell
        Set rngLastUsedCell = ActiveSheet.Cells.Find(What:="*", _
                                               After:=ws.Cells(1, 1), _
                                               LookIn:=xlFormulas, _
                                               LookAt:=xlPart, _
                                               SearchOrder:=xlByRows, _
                                               SearchDirection:=xlPrevious, _
                                               MatchCase:=False)

    'Pass object to function
        Set GetLastUsedCell = rngLastUsedCell
    
    'Tidy up
        Set rngLastUsedCell = Nothing
        
End Function

Returns:

$O$77

Perfect! That’s what I was looking for. Now I need to find the first used cell.

First Used Cell Function

In pure violation of the recommendation of Bovey et. al., in their landmark tome, Professional Excel Development: The Definitive Guide to Developing Applications Using Microsoft Excel, VBA, and .NET (2nd Edition), I generally begin all of my worksheets at $A$1, but not always. So I need a function to find the first used cell on the worksheet no matter what worksheet I throw at the function.

Private Function GetFirstUsedCell(ws As Worksheet) As Range

    'Declare variables
        Dim rng As Range
        
    'Create range object from the first cell in the UsedRange
        Set rng = ws.UsedRange.Cells(1, 1)

    'Pass object to function
        Set GetFirstUsedCell = rng
    
    'Tidy up
        Set rng = Nothing
        
End Function

Returns:

$A$1

Excellent! That’s what I was looking for. Now that I have the first and last cells of the true UsedRange, I need to use the first cell and last cell to create a range of everything.

Create A Big Range

Private Function GetBigRange(ws As Worksheet, _
                             rngStart As Range, _
                             rngStop As Range) As Range
                             
    'Declare variables
        Dim rng As Range
        
    'Creat a range object from start and stop range positions
        Set rng = ws.Range(rngStart, rngStop)
        
    'Pass range object to function
        Set GetBigRange = rng
        
    'Tidy up
        Set rng = Nothing
                             
End Function

Returns:

$A$1:$O$77

Awesome! Now, I can use the entire range to generate random values to use for the ActiveCell.

Get Values

I’ll need to call a get value function 4 times to get the first row, the last row, the first column and the last column.

Here’s the function:

Private Function GetValueFromRange(rng As Range, _
                                   strType As String) As Long
    
    'Declare variables
        Dim x As Long
        
    'Get value depending on type
        With rng
            Select Case strType
                Case "FirstRow"
                    x = .Row
                Case "LastRow"
                    x = .Rows.Count
                Case "FirstColumn"
                    x = .Column
                Case "LastColumn"
                    x = .Columns.Count
            End Select
        End With
        
    'Pass value to function
        GetValueFromRange = x
     
End Function

And here is how I called the function 4 different times:

'Get values form total used range
        BeginRow = GetValueFromRange(rng:=rngAll, _
                                     strType:="FirstRow")
                                     
        EndRow = GetValueFromRange(rng:=rngAll, _
                                   strType:="LastRow")
                                   
        BeginColumn = GetValueFromRange(rng:=rngAll, _
                                   strType:="FirstColumn")
                                   
        EndColumn = GetValueFromRange(rng:=rngAll, _
                                   strType:="LastColumn")

Returns:

  • BeginRow 1
  • EndRow 77
  • BeginColumn 1
  • EndColumn 15
  • Gnarly! Now, I have the values that I can pass to a function to generate a random cell reference.

    Get Random Values

    Now that I have high-low pairs for rows and columns, I can use the Worksheet Function Randbetween to generate some random values for the row and column numbers.

    Private Function GetRandomValue(ValueLow As Long, _
                                    ValueHigh As Long) As Long
    
        'Declare variables
            Dim x As Long
            
        'Generate a random value
            x = Application.WorksheetFunction.RandBetween(ValueLow, ValueHigh)
            
        'Pass value to the function
            GetRandomValue = x
    
    End Function
    

    And here is how I call the function to get a random row and a random column:

                        'Get random row
                            RandomRow = GetRandomValue(ValueLow:=BeginRow, _
                                                       ValueHigh:=EndRow)
                                                       
                        'Get random column
                            RandomColumn = GetRandomValue(ValueLow:=BeginColumn, _
                                                          ValueHigh:=EndColumn)
    

    Go There!

    Once I have a Row and Column number, I can use the Cells property of the Worksheet Object in conjunction with the GoTo Method of the Excel Application Object to go to the desired cell:

                        'Go to the cell
                            Application.GoTo ws.Cells(RandomRow, RandomColumn), _
                                                      Scroll:=True
    

    ActiveCellOutput

    Bam! I sent the Worksheet Name and the ActiveCell Address to the Immediate Window.

    Let’s Go!

    Recall, the end in mind is to set the ActiveCell to the same cell on every sheet to aid in our visual review of each worksheet in the workbook. I introduced the Code Snippet just a few lines up:

                        'Go to the cell
                            Application.GoTo ws.Cells(RandomRow, RandomColumn), _
                                                      Scroll:=True
    

    So I just need to pass 2 values of datatype long and I can go to any cell I want. So to GoTo R1C1 is merely:

                        'Go to the cell
                            Application.GoTo ws.Cells(1, 1), _
                                                      Scroll:=True
    

    Pow! The ActiveCell on every Worksheet is now R1C1 (A1). The review is much more pleasurable.

    But I want flexibility!

    What if you want to set the ActiveCell as $R$10 on every Worksheet, next time you want $C$12 – you get the point – enter the InputBox.

    Get Input

    I previously demonstrated a function to allow the user to select a cell here. Read more about using InputBoxes and the various types on MSDN

    For my purposes, I want the user to select a cell, so I will use Type:=8 for my InputBox:

    Public Function GetCell(ws As Worksheet) As Range
         
        'Declare variables
            Dim rng                         As Range
         
        'Users - select a cell on a worksheet
            Set rng = Application.InputBox( _
                                           Prompt:="Please select a cell on the worksheet", _
                                           Title:="Select a cell", _
                                           Default:=ActiveCell.Address, _
                                           Type:=8) 'Range selection
             
        'Pass the range object to the function
            Set GetCell = rng
         
        'Tidy up
            Set rng = Nothing
    
     End Function
    

    Now, I will test the GetCell Function:

    Option Explicit
    
    Sub testit()
    
        Dim wb As Workbook
        Dim ws As Worksheet
        Dim C As Range
        
        Set wb = ThisWorkbook
        Set ws = wb.Worksheets("PL_CC")
        Set C = GetCell(ws:=ws)
        
        Debug.Print C.Address
        
        Set C = Nothing
        Set ws = Nothing
        Set wb = Nothing
    
    End Sub
    

    And spin the test code:

    SelectCellPrompt

    I am prompted to select a cell on the worksheet. I clicked on cell $C$8.

    ClickCellOutput

    Shazam! That worked perfectly! I can move the Function into production and dynamically let the user choose what should be the ActiveCell on every Worksheet.

    Option Explicit
    
    Sub SetActiveCell()
        
        'Declare variables
            Dim wb As Workbook
            Dim ws As Worksheet
            Dim wsPL As Worksheet
            Dim C As Range
            Dim userRow As Long
            Dim userColumn As Long
        
        'Initialize
            Set wb = ThisWorkbook
            Set wsPL = wb.Worksheets("PL_CC")
            Set C = GetCell(ws:=wsPL)
        
            With C
                userRow = .Row
                userColumn = .Column
            End With
        
        'Set the ActiveCell on each worksheet
            For Each ws In wb.Worksheets
                If InStr(ws.Name, "PL") Then
                    Application.GoTo ws.Cells(userRow, userColumn), _
                                    Scroll:=True
                End If
            Next ws
        
        'Tidy up
            Set C = Nothing
            Set wsPL = Nothing
            Set wb = Nothing
            
    End Sub
    

    ActiveCellC8

    All worksheets with “PL” as part of the name are now active on cell $C$8. Much easier to review!

    Tidy Up

    I’m outta here. I just landed on Boardwalk and the kid has the monopoly with a hotel – I’m pretty sure I’m bankrupt!

    BankruptFinal

    , , , , , , , , ,

    UndauntedFinalII

    Some time back, Shane Devenshire and I added our two cents to a question a user asked on LinkedIn here. So when I decided to write a post regarding UnPivot using nested For..Next Loops, it only made sense to ask Shane if he would like to write a guest-post and tutorial on his process and Normalization Utility.

    So, without further ado, take it away Shane!

    Un-pivoting Excel Spreadsheet data – Creating a Normalized Table

    Introduction:
    Recently I was working with Tableau and discovered that the company had an Excel add-in for taking data laid out like a pivot table or standard spreadsheet layout:

    SDTable1

    And converting it to data laid out like a table (normalized):

    SDTable2

    When I tested the add-in on a large data it took over an hour. I knew I could do this faster, even manually, but I decided to automate the process, which uses a number of Excel’s built-in features. The attached is the initial result of this endeavor.

    When one wants to convert spreadsheet data, laid out as in a pivot table, into what is called a normalized database or table one can use a VBA approach which loops through cells rearranging the data and copying repeated data as many times as necessary. You could do this manually but it’s rather labor intensive. However, even the looping approach is not very efficient, which becomes apparent when the data sets are large. An alternate approach using some of Excel’s less familiar features can speed up the process dramatically.

    I created the three step wizard shown below to provide some enhancements:

    In the first step, see Figure 1, the user indicates the top left corner of the values area, the sample show what we are looking for. This allows the VBA routine to decide where the column titles are and which columns will be retained in their default structure and which column will be “transposed” (placed in a singe “values” column.

    Figure 1 – First step of the Wizard:

    SDTable3

    If the user clicks Finish, the code accepts all the defaults and created the normalized table. If the user clicks Next the second step of the Wizard is displayed, see Figure 2.

    Figure 2 – This is the second step of the Wizard:

    SDTable4

    Here the Wizard displays the first ten fields to the left of the values area allowing the user to choose which ones to include. If there are dates at the top of the values area a default name for the new field is Date which is automatically entered in the Field Name box which the user can change or leave blank. The Delimiter box allows the user to indicate what delimiter to use when concatenating the fields together (discussed later). The delimiter should not be a character found in the chosen fields on the left in the dialog box.

    Clicking Next brings you to the third step of the wizard, shown in Figure 3.

    Figure 3 – This is the third step of the Wizard:

    SDTable5

    The first two options on this screen allow the user to retain or remove rows of data in the output table which have either a 0 (zero) or are blank in the values column. This reduces the file size when appropriate. Because the Excel feature used to normalize the data generates an Excel “table”, the last three options allow the user to turn on or off various features of tables or convert the table to a range.

    Overview:

    You can create a pivot table in Excel with a feature called Multiple Consolidation Ranges. You can then use the Show Details command on the Grand/Grand Total to produce a normalized table. Both of these commands are very fast! One limitation of this command is that is was designed to be used with data which has only one label field to the left of the values area. To bypass this limitation one can combine all the label fields by using a concatenation formula, but to later break it apart a delimiter is need. Then the multiple consolidation command is run against this one field and all of the value columns. The concatenated field of the output is then parsed using Excel’s Text to Columns command with the delimiter specified by the user. These steps are very fast. As noted in the discussion of step 3 of the Wizard, I have also incorporated a number of additional options.

    I create two modules and a user form to control this process. All of the code and form can be found in the attached file. I have tried not to obfuscate the code. There are four main components to consider

    Option Explicit		
    Dim k	As Integer	number of fields to be output
    		
    Sub NormalizeData()		
    Dim sTempSheet	As String	Name of the sheet where the pivot table is placed
    Dim j	As Integer	loop counter
    Dim i	As Integer	loop counter
    Dim sMyFormula	As String	the concatenated formula
    Dim sMySheet	As String	Name of the sheet where initial data is
    Dim lMyColumn	As Long	column number of column used for concatenated formula
    Dim sDataSheet	As String	Name of the sheet where the final output is placed
    Dim sSource	As String	Source range for the pivot table
    Dim sMyTitles	As String	The concatenated titles
        		
        'Speeds things up		
        With Application		
            .ScreenUpdating = False	
            .Calculation = xlCalculationManual	
        End With		
        		
        sMySheet = ActiveSheet.Name	
        		
        'uses the ref edit address to place the cursor in the top left corner of the values to be transposed
        Range(frmNormalize.refFirstData).Activate
        		
        'Inserts new blank column for concatenation formula
        ActiveCell.EntireColumn.Insert	
        lMyColumn = ActiveCell.Column	
        		
        'initializes loop counters		
        j = 1		
        k = 0		
        		
        'loops through each column and concatenates it if that column was choosen
        'this loop runs a max of ten times	
        For i = iTotCols To 1 Step -1	
            If frmNormalize.Controls("Checkbox" & j) = True Then
                If sMyFormula = "" Then	
                    sMyFormula = "=RC[" & -i & "]"	
                Else		
                    sMyFormula = sMyFormula & "&" & """" & sDelimiter & """" & "&RC[" & -i & "]"
                End If		
                k = k + 1		
            End If		
            j = j + 1		
        Next i		
    

    The above code creates a concatenation formula of the forma =A5&”*”&B5&”*”&C5, which is then converted to values like 2008*Coffee*Seattle. The above code loops once to build the concatenated formula for a single row, and then fills it down. All very fast. The delimiter must be unique because it will be used by the Text to Columns command to parse the data.

        'Selects the title row and inserts the formula there.
        'Here it will be the concatenated titles	
        ActiveCell.Offset(-1, 0).Select	
        ActiveCell = sMyFormula		
        Range(ActiveCell, Cells(lLastRow, ActiveCell.Column)).FillDown
        ActiveSheet.Calculate		
        		
        'converts the range to values	
        Selection = Selection.Value	
        		
        'the concatenated titles is saved for later use since it would be lost during the next commands
        sMyTitles = ActiveCell		
        		
        'Creates "consolidated ranges" pivot table, which will later be removed
        sSource = Range(Cells(lFirstDataRow - 1, lFirstDataColumn), Cells(lLastRow, lLastColumn)).Address(, , xlR1C1)
        ActiveWorkbook.PivotCaches.Create(SourceType:=xlConsolidation, _
            SourceData:=sSource).CreatePivotTable _
            TableDestination:="", _	
           TableName:="NPT"		
        On Error Resume Next	
        ActiveSheet.PivotTables("NPT").PivotFields("Count of Value").Function = xlSum
    

    The above code is one of the steps that make this process so fast. Excel builds a “consolidated range” pivot table. If some of the data is non-numeric the data field would use “Count” which we want to convert to “Sum”, this is the reason for lines 67 and 68. Manually you can reach this command by pressing Alt+D+P to expose the PivotTable and PivotChart Wizard from Excel 2003, shown in Figure 4, below:

    Figure 4 – This is the first step of Microsoft’s Wizard, which the code is emulating:

    SDTable6

    The command we are using is Multiple consolidation ranges. Excel gives us a pivot table which Is, in and of itself, not very useful. But in the following code, the ShowDetail command used on the Grand/Grand Total creates the desired output. And it’s very fast!

        'creates database detail from the above pivot table, which is pretty much what we want
        sTempSheet = ActiveSheet.Name	
        ActiveCell.SpecialCells(xlLastCell).ShowDetail = True   'Generates normalized database
        		
        'you can turn off these alerts earlier in the macro but its often safer to turn them of and on only where needed
        ‘The pivot table sheet is no longer need and can be deleted
        With Application		
            .DisplayAlerts = False		
            Sheets(sTempSheet).Delete	
            .DisplayAlerts = True
    

    The following code first inserts some blank columns and then uses Excel’s Text to Columns command to convert the concatenated field back to its original individual fields. Yet another very fast command!

            'inserts as many columns as need to display all the concatenated fields
            Range("B1:" & Cells(1, k).Address).EntireColumn.Insert
            'puts the concatenated titles in cell A1
            Range("A1") = sMyTitles
            Range("A1", [A1].End(xlDown)).Select
            
            'the text to columns command overwrites the table's default titles
            .DisplayAlerts = False
        
            'converts concatenated field to a set of columns
            Selection.TextToColumns _
                Destination:=Range("A1"), _
                DataType:=xlDelimited, _
                ConsecutiveDelimiter:=False, _
                Other:=True, _
                OtherChar:=sDelimiter
            .DisplayAlerts = True
        End With
        
        'best fit the data
        Range("A1:" & Cells(1, iTotCols).Address).EntireColumn.AutoFit
        
        'enters the field name for the transposed row
        Range("A1").Offset(0, k) = frmNormalize.txtNewFieldName
        
        'Options - removes rows With blanks or zeros in the value field
        If frmNormalize.cbBlanks = True Then
            RemoveBlanks
        End If
        If frmNormalize.cbZeros = True Then
            RemoveZeros
        End If
        ConvertToRange
        
        'Cleanup
        sDataSheet = ActiveSheet.Name
        Sheets(sMySheet).Activate
    
       ‘removes the concatenated formula column from the original data.
        Cells(1, lMyColumn).EntireColumn.Delete    
        Sheets(sDataSheet).Activate
        Application.Calculation = xlCalculationAutomatic
        
    End Sub
    

    Deleting rows can be done by looping from the bottom and deleting each row that meets a given condition. This is very slow! If you can select all the rows which meet some condition you can then delete them with one command. This is faster. However, if Excel needs to adjust cell references based on the deleted rows this can also slow things down. One solution is to move all the rows you want to delete to the bottom of the dataset and then delete them with a single command. In the following two modules something like that is done. For removing rows with blanks in the values column you simple need to sort by the values and the use the Go to Special, Blanks command to select all the rows.

    RemoveBlanks Subroutine

    Removes rows with blanks in value column
    Private Sub RemoveBlanks()
        
        'puts all blank cells at the bottom of the table making deleting rows faster
        With ActiveSheet.Sort
            .SortFields.Clear
            .SortFields.Add _
                Key:=Cells(1, k + 2), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending
            .SetRange ActiveCell.CurrentRegion
            .Header = xlYes
            .Orientation = xlTopToBottom
            .Apply
        End With
        
        'this command deletes all rows with blanks in the values column
        Selection.Offset(0, k + 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End Sub
    

    Removing zeros is a little trickier, because, if the user has chosen not to remove blanks you can’t clear all cells with 0’s and then run the above command, extra row may be deleted. In this case you can replace the 0’s with text, then clear the cells with zeros and then use line 18 above to remove the rows. Finally you can clear the cells containing text. I chose not to do that; instead I entered the formula =1/0 in all the cells with 0 and then sorted putting this group near the bottom. Then I selected an deleted all the cells with error formulas with one step, line 25.

    RemoveZeros Subroutine

    This code removes all rows with zeros in the values field
    Private Sub RemoveZeros()
        
        'replaces all cells with 0 with a formula generating an DIV/0! error
        Range("A1").CurrentRegion.Resize(, 1).Offset(0, k + 1).Select
            Selection.Replace _
                What:="0", _
                Replacement:="=1/0", _
                LookAt:=xlWhole
            
        'this sorts all cells with errors to the bottom making deleting rows faster
        With ActiveSheet.Sort
            .SortFields.Clear
            .SortFields.Add _
                Key:=Cells(1, k + 2), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending
            .SetRange ActiveCell.CurrentRegion
            .Header = xlYes
            .Orientation = xlTopToBottom
            .Apply
        End With
        
        'this command deletes all rows with errors
        Selection.SpecialCells(xlCellTypeFormulas, 16).EntireRow.Delete
    End Sub
    

    ConvertToRange Subroutine

    'The user can keep the table or convert it to a regular spreadsheet range
    'The user can keep or remove the autofilters in either case
    'The user can keep or remove the formatting in either case
    Private Sub ConvertToRange()
        Dim rList As Range
     
        With ActiveSheet.ListObjects(1)
            Set rList = .Range
            If frmNormalize.cbConvertToRange = True Then
                .Unlist                                                                     'converts a table to a range
                If frmNormalize.cbFilter = False Then Range("A1").CurrentRegion.AutoFilter  'turns on  autofilter
                If frmNormalize.cbFormatting = True Then                                    'removes table formatting
                    With rList
                        .Interior.ColorIndex = xlColorIndexNone
                        .Font.ColorIndex = xlColorIndexAutomatic
                        .Borders.LineStyle = xlLineStyleNone
                    End With
                End If
            Else
                If frmNormalize.cbFilter = True Then .Range.AutoFilter  'Turns off autofilter
                If frmNormalize.cbFormatting = True Then                'Turns off table formatting
                    .TableStyle = ""
                End If
            End If
        End With
    End Sub
    

    Tidy Up

    That’s it for today. HUGE thanks to Shane Devenshire for sharing his Data Normalization Utility with us and allowing me to post it on my blog. I hope you enjoy it and find it useful in your daily work.

    Downloads

    Download the file from OneDrive. The zip archive contains the Data Normalizer in .xlsm format as well as a Microsoft Word version of the tutorial.

    Other posts regarding data normalization or “UnPivot” at dataprose.org

      Undaunted by UnPivot

    Other posts regarding data normalization or “UnPivot” around the horn

      UnPivot Shootout – DDoE
      Reshape Data
    , ,

    UndauntedFinal

    Well, maybe an UnPivot or Reverse CrossTab process in Excel with VBA does not require the same amount of courage as Meriwether Lewis (pictured here) must have had as he and Clark set out on their exploration of the Louisiana Territory – nonetheless, the process can seem a bit overwhelming to a newcomer. I’ll do my best to explain it in a straight-forward manner.

    Many times, we receive data in a crosstab format but we want it in a normalized format suitable for use with Pivot Tables or Excel Tables :

    Crosstab

    Here’s a fairly standard layout to retrieve data from a P&L Cube in Essbase using the Essbase Spreadsheet Add-in. This layout, however, is not conducive for creating PivotTables or for analyzing with Excel Tables. There are ways in Essbase to get this is a better “Normalized” format, but I have this at hand so it suits my needs for now.

    Tell Me What You Need….

    CrosstabMarkup

    I marked-up the spreadsheet to show which fields I am interested in and in what order I would like them in the final output :

    1. Organization – Some division, region, district, store in the company under analysis
    2. Scenario – Budget, Forecast, Actual and various versions of the aforementioned
    3. Time – I’m showing periods in the screen shot, could be any measure of time
    4. Accounts – The name and or number of the account
    5. Measure – What we are really interested in : Amounts, statistics, ratios, etc…

    How Would You Like That….

    Here is the desired output :

    CrosstabOutput

    Some of the values in the desired output are static, that is, the same value from the same cell must be output over and over again. Other times, I need to move across columns and still others I need to move down rows

    Segue To Some Functions…

    I’ll need a coupe of Functions so that my code is dynamic to some extent. I do not know the last column or the last row during development stage so I will need to determine those values at run-time.

    Last Used Column

    This function has only one argument, a worksheet, it will return the column number of the last used cell on the worksheet

    Public Function GetLastColumn(ws As Worksheet) As Long
    
        'Input  :   Worksheet
        'Output :   A column number of type long
        
        'Declare variables
            Dim rng As Range
            Dim lngColumn As Long
            
        'Get range address of last cell on worksheet
            Set rng = ws.Cells.SpecialCells(xlCellTypeLastCell)
        
        'Get column number of last cell
            lngColumn = rng.Column
            
        'Pass value to function
            GetLastColumn = lngColumn
        
        'Tidy up
            Set rng = Nothing
            
    End Function
    

    Last Used Row

    This function has only one argument, a worksheet, it will return the row number of the last used cell in Column A :

    Public Function GetRows(ws As Worksheet) As Long
    
        'Input          :   Worksheet
        'Output         :   A row number of type long
        'Assumptions    :   First column (A)
        
        'Declare variables
            Dim r As Long
        
        'Get last row
            With ws
                r = .Cells(Rows.Count, 1).End(xlUp).Row
            End With
            
        'Pass value to function
            GetRows = r
            
    End Function
    

    The Main Procedure

    Here is the main procedure. The main thing to pay attention to is the different variable and static cell values used to get the correct output. Take a look at the code inside the For..Next Loops :

    Option Explicit
    
    Sub UnPivotData()
    
        'Purpose    :   Convert crosstab data to normalized data
        'Author     :   Winston Snyder
        'Date       :   5/26/2014
    
        'Declare variables
            Dim wb As Workbook
            Dim wsData As Worksheet
            Dim wsDataNormalized As Worksheet
            Dim MaxColumns As Long
            Dim MaxRows As Long
            Dim i As Long
            Dim j As Long
            Dim k As Long
    
        'Excel environment - speed things up
            With Application
                .ScreenUpdating = False
                .DisplayAlerts = False
                .EnableEvents = False
                .Calculation = xlCalculationManual
            End With
    
        'Objects
            Set wb = ThisWorkbook
            With wb
                Set wsData = .Worksheets("Data")
                Set wsDataNormalized = .Worksheets("Normal")
            End With
    
        'Initialize
            wsDataNormalized.UsedRange.ClearContents
            MaxColumns = GetLastColumn(ws:=wsData)
            MaxRows = GetRows(ws:=wsData)
            k = 2
    
        'Convert cross-tab report to normalized data table structure
            With wsDataNormalized
                For i = 6 To MaxRows 'Begin with first row of (Measures)
                    For j = 2 To MaxColumns 'Begin with first column of data (Measures)
                        .Cells(k, 1).Value = wsData.Cells(4, 1).Value   'Organization
                        .Cells(k, 2).Value = wsData.Cells(2, 1).Value   'Scenario
                        .Cells(k, 3).Value = wsData.Cells(5, j).Value  'Time
                        .Cells(k, 4).Value = wsData.Cells(i, 1).Value  'Account
                        .Cells(k, 5).Value = wsData.Cells(i, j).Value  'Measure
                        k = k + 1
                    Next j
                Next i
    
                'Add headers
                .Range("A1").Value = "Organization"
                .Range("B1").Value = "Scenario"
                .Range("C1").Value = "Time"
                .Range("D1").Value = "Account"
                .Range("E1").Value = "Measure"
            End With
    
        'Tidy up
            'Destroy objects
                Set wsDataNormalized = Nothing
                Set wsData = Nothing
                Set wb = Nothing
    
            'Restore Excel environment
                With Application
                    .ScreenUpdating = True
                    .DisplayAlerts = True
                    .EnableEvents = True
                    .Calculation = xlCalculationAutomatic
                End With
    End Sub
    

    CrosstabOutputNormal

    Perfect Ready to Pivot or analyze with Excel Tables an Structured Reference Formulas.

    It’s About Time….

    I’m going to add a couple of lines to the Sub() to see how long it takes. I’ll use the GetTickCount function from the Windows kernel32 library :

    Option Explicit
    Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
    
    Sub UnPivotData()
    
        'Purpose    :   Convert crosstab data to normalized data
        'Author     :   Winston Snyder
        'Date       :   5/26/2014
        
        'Start timer
            Dim t As Long
            t = GetTickCount
    
        'Declare variables
            Dim wb As Workbook
            Dim wsData As Worksheet
            Dim wsDataNormalized As Worksheet
            Dim MaxColumns As Long
            Dim MaxRows As Long
            Dim i As Long
            Dim j As Long
            Dim k As Long
    
        'Excel environment - speed things up
            With Application
                .ScreenUpdating = False
                .DisplayAlerts = False
                .EnableEvents = False
                .Calculation = xlCalculationManual
            End With
    
        'Objects
            Set wb = ThisWorkbook
            With wb
                Set wsData = .Worksheets("Data")
                Set wsDataNormalized = .Worksheets("Normal")
            End With
    
        'Initialize
            wsDataNormalized.UsedRange.ClearContents
            MaxColumns = GetLastColumn(ws:=wsData)
            MaxRows = GetRows(ws:=wsData)
            k = 2
    
        'Convert cross-tab report to normalized data table structure
            With wsDataNormalized
                For i = 6 To MaxRows 'Begin with first row of (Measures)
                    For j = 2 To MaxColumns 'Begin with first column of data (Measures)
                        .Cells(k, 1).Value = wsData.Cells(4, 1).Value   'Organization
                        .Cells(k, 2).Value = wsData.Cells(2, 1).Value   'Scenario
                        .Cells(k, 3).Value = wsData.Cells(5, j).Value  'Time
                        .Cells(k, 4).Value = wsData.Cells(i, 1).Value  'Account
                        .Cells(k, 5).Value = wsData.Cells(i, j).Value  'Measure
                        k = k + 1
                    Next j
                Next i
    
                'Add headers
                .Range("A1").Value = "Organization"
                .Range("B1").Value = "Scenario"
                .Range("C1").Value = "Time"
                .Range("D1").Value = "Account"
                .Range("E1").Value = "Measure"
            End With
    
        'Tidy up
            'Destroy objects
                Set wsDataNormalized = Nothing
                Set wsData = Nothing
                Set wb = Nothing
    
            'Restore Excel environment
                With Application
                    .ScreenUpdating = True
                    .DisplayAlerts = True
                    .EnableEvents = True
                    .Calculation = xlCalculationAutomatic
                End With
                
        'Timer
            MsgBox GetTickCount - t & " Milliseconds", , " Milliseconds"
    
    End Sub
    

    I ran three trials of the revised code to check the timer. It ran in 62 ms, 78 ms and 62 ms respectively.

    Tidy Up

      UnPivot

        UnPivot Shootout – DDoE
        Reshape Data

      Essbase

        Hyperion Essbase
        Hyperion Essbase Spreadsheet Add-In

      kernel32.dll

        kernel32.dll
        kernel32 documentation
      ,

    MrCleanFinalFinal

    In my last post on working with strings, I demonstrated some VBA with a call to the Regular Expression (RegExp) library to split alpha characters from numeric characters where no delimiter was present. Today I received a data set that contained 10’s of thousand of strings that contained some trailing stuff that I wanted to remove. My initial thought was to use the RegExp engine with the correct pattern, but I discovered a better way.

    The Requirements

    Upon review of the strings, the pattern I discovered:

    1. The string always begin with an alpha or numeric character with a mix of upper and lower case
    2. The string I need to preserve end with an alpha or numeric character with a mix of upper and lower case
    3. Everything from the beginning of the of the first alphanumeric to the last alphanumeric must be preserved as is, spaces, case, special characters, whatever
    4. Everything trailing to right of the last alphanumeric may safely be removed, special characters, non-printable characters, spaces, whatever
    5. Strings are of random lengths both input and output

    So, I need to :

    1. Search from the end (right) of the string
    2. Find the first alphanumeric character irregardless of case
    3. Return the string beginning from the first character to the character position determined in the previous step

    Quick Segue – The Functions

    Before I get to the Sub Procedure, I would like to review all of the Functions I am using to make the process fairly dynamic :

    GetSelectedSheet

    Here I am using an InputBox to allow the user to select a worksheet at run-time. The InputBox Method has 1 required parameter and 7 optional parameters. If the optional parameters are not utilized, then the InputBox returns a text value. However, The optional Type parameter makes the InputBox more powerful. In the function, I am using Type:=8 to return a cell reference as a Range Object. You can read more about the InputBox Method here.

    Public Function GetSelectedSheet() As String
        
        'Declare variables
            Dim ws                          As Worksheet
            Dim rng                         As Range
        
        'Users - select a cell on a worksheet
            Set rng = InputBox( _
                        Prompt:="Please select a cell on a worksheet", _
                        Title:="Select a worksheet", _
                        Default:=ActiveCell.Address, _
                        Type:=8) 'Range selection
                        
        'Get the parent worksheet of the selected cell
            Set ws = rng.Parent
            
        'Pass the name of the worksheet to the function
            GetSelectedSheet = ws.Name
        
        'Tidy up
            Set rng = Nothing
            Set ws = Nothing
     End Function
    

    GetRows

    Fairly straight forward, I pass the selected worksheet to the function and it returns the maximum rows of data based on Column 1. I could make this more dynamic by passing a column number to the function as well, but I generally always use Column 1.

    Public Function GetRows(ws As Worksheet) As Long
    
        Dim r As Long
        
        With ws
            r = .Cells(Rows.Count, 1).End(xlUp).Row
        End With
        
        GetRows = r
    End Function
    

    GetColumns

    Straight forward, I pass the selected worksheet to the function and it returns the maximum columns of data based on Row 1. I could make this more dynamic by passing a row number to the function as well, but I generally always use Row 1.

    Public Function GetColumns(ws As Worksheet) As Long
    
         'Declare variables    
               Dim c As Long
        
         'Get column count, store it in a variable    
              With ws
                   c = .Cells(1, Columns.Count).End(xlToLeft).Column
              End With
    
         'Pass the variable value to the function
              GetColumns = c
    End Function
    

    GetUserInput

    Again, fairly straight forward. Get a text value from the user to search for in the next function.
    I call the function like this :

        'User - What is search term?
            strSearchTerm = GetUserInput(strPrompt:="What is the search term?", _
                                         strTitle:="Find Column Number")
    
    Public Function GetUserInput(strPrompt As String, _
                                 strTitle As String) As String
           
        'Declare variables
             Dim strUserInput As String
           
        'Call the InputBox Method, pass user input to a variable
              strUserInput = InputBox(Prompt:=strPrompt, _
                                      Title:=strTitle)
    
        'Pass the variable value to the function                                 
             GetUserInput = strUserInput
    
    End Function
    

    GetColumnNumber

    The function has 2 arguments, a worksheet and a string value that I got from the user in the last function. The function will create a Range Object and search that Range for the term supplied by the user. Again, I am using Row 1 here, but I could make it more dynamic by passing a row number to the function as one of its arguments. Below, I am using the Named Argument, LookAt:= and passing the value xlPart instead of xlWhole. You may want to consider this in your VBA Projects as you program defensively around what the user may input. Since I am using this for myself, I am not too concerned for now,

    Public Function GetColumnNumber(ws As Worksheet, _
                                    strSearchTerm As String) As Long
    
        'Declare variables
            Dim rng As Range
            Dim MaxColumns As Long
            Dim lngField As Long
            
        'Initialize
            MaxColumns = GetColumns(ws:=ws)
            With ws
                Set rng = .Range(.Cells(1, 1), .Cells(1, MaxColumns))
            End With
            
        'Find columns number
            lngField = rng.Find(What:=strSearchTerm, _
                                LookIn:=xlValues, _
                                LookAt:=xlPart, _
                                MatchCase:=False).Column
                                
        'Pass the column number to the function
            GetColumnNumber = lngField
            
        'Tidy up
            Set rng = Nothing
    
    End Function
    

    GetCleanAlphaNumeric

    This is the money! All other functions to this point were setup work to allow this function to do the heavy lifting. The function uses the LIKE operator to compare a character beginning at the right-most position of the string to the pattern, “[0-9A-Za-z]”. As soon as a match is found, the For..Next Loop is exited, thus saving time by not checking characters unnecessarily. I then use the MID() Function to get the string from the 1st character to the last alphanumeric character position determined in the For..Next Loop. More on the LIKE operator here.

    Public Function GetCleanAlphaNumeric(strChar As String) As String
        
        'Comments   :   Remove non-alpha numeric characters from end of string
       
        'Declare variables
            Dim i As Long
            Dim lngLengthString As Long
            Dim blnTest As Boolean
            Dim posLastAlphaNumeric As Long
            Dim strClean As String
       
        'Initialize
            blnTest = False
    
        'Length of string to check
            lngLengthString = Len(CStr(strChar))
            
        'Compare each charcter to pattern
        'Begin at end of string
        'Stop as soon as find alphanumeric
            For posLastAlphaNumeric = lngLengthString To 1 Step -1
                blnTest = Mid(CStr(strChar), posLastAlphaNumeric, 1) Like "[0-9A-Za-z]"
                If blnTest = True Then Exit For
            Next posLastAlphaNumeric
            
        'posLastAlphaNumeric is the position of last AlphaNumeric character
        'Use the position of the last alphanumeric to get the final length of the string
        'Assign the value to the range
            strClean = CStr(Mid(strChar, 1, posLastAlphaNumeric))
            
        'Pass the clean string to the function
            GetCleanAlphaNumeric = strClean
    
     End Function
    

    The Main Procedure

    Here is the main procedure that calls all of the functions. Note: Screen updating must be on for the user to select a cell on a worksheet. Turn ScreenUpdating off after the user selects a cell on a worksheet.

    Option Explicit
    Sub CleanStrings()
         
        'Author:        Winston Snyder
        'Date:          3/28/14
        'Purpose:       Get string excluding non-alphanumeric trailing characters
        '---------------------------------------------------------------------------------------------------------------------------------------------
         
        'Declare variables
            Dim wb                                  As Workbook
            Dim ws                                  As Worksheet
            Dim rng                                 As Range
            Dim C                                   As Range
            Dim strSearchTerm                       As String
            Dim strStringToBeCleaned                As String
            Dim lngColumnNumber                     As Long
            Dim MaxRows                             As Long
         
        'Excel environment - speed things up
            With Application
                .DisplayAlerts = False
                .EnableEvents = False
                .Calculation = xlCalculationManual
            End With
         
        'Initialize
            Set wb = ThisWorkbook
            Set ws = wb.Worksheets(GetSelectedSheet)
            Application.ScreenUpdating = False
            
        'Get maximum number of rows on the worksheet
            MaxRows = GetRows(ws:=ws)
             
        'User - What is search term?
            strSearchTerm = GetUserInput(strPrompt:="What is the search term?", _
                                         strTitle:="Find Column Number")
                                         
        'Get the column number based on the search term
            lngColumnNumber = GetColumnNumber(ws:=ws, _
                                              strSearchTerm:=strSearchTerm)
                                              
        'Define the range that contains strings to be cleaned
            With ws
                Set rng = .Range(.Cells(2, lngColumnNumber), .Cells(MaxRows, lngColumnNumber))
            End With
            
        'Clean each string in the range
            For Each C In rng
                strStringToBeCleaned = CStr(C.Value)
                C.Value = GetCleanAlphaNumeric(strChar:=strStringToBeCleaned)
            Next C
    
        'Tidy up
                 
            'Destroy objects
                Set C = Nothing
                Set rng = Nothing
                Set ws = Nothing
                Set wb = Nothing
                 
            'Restore Excel environment
                With Application
                    .ScreenUpdating = True
                    .DisplayAlerts = True
                    .EnableEvents = True
                    .Calculation = xlCalculationAutomatic
                End With
    End Sub
    

    Tidy up

      Final Thoughts

      That’s it today. I like the LIKE operator. This process is fast, reviewed 25K strings, and updated them when needed in no time. Awesome!

    ,