Archive for the ‘VBA’ Category

SQL to escape all SQL wildcard characters in a string:

DECLARE @DirtyString nvarchar(1000) = ‘How\now % [brown_cow]’;
DECLARE @CleanString nvarchar(1000);

SET @CleanString = REPLACE(REPLACE(REPLACE(REPLACE(REPLACE(@DirtyString, ‘\’, ‘\\’, ‘%’, ‘\%’), ‘_’, ‘\_’), ‘[‘, ‘\[‘), ‘]’, ‘\]’);

PRINT ‘@CleanString = ‘ + @CleanString;


Read Full Post »

I have played around with VSTO over the last few years but always found it to be too quirky, awkward and difficult to deploy, and so never considered using it for serious development. The version that shipped with VS 2008, and targeted Office 2007, was as buggy as Office 2007 itself. However, with the release of Visual Studio 2013 Community Edition and Office 2013, I thought it was time to give it another try.

It’s become apparent (to me, anyway) that VBA is finally going the way of the dinosaurs. Microsoft’s decision to not replace the 32-bit ActiveX controls with 64-bit versions, thus making VBA development near impossible in 64-bit Office, was the final warning that we need to “move on”. I don’t think I’m ready to make the transition to Apps for Office. Plugging HTML and Javascript-powered browser apps into my Excel workbooks still sounds a bit too experimental to me. But harnessing the full power of Visual Studio and the .Net libraries for use in my Excel applications appears to be a better bet.

It is difficult to locate any comprehensive VSTO examples on the web, so I decided to create my own in a series of posts that cover everything from the very basics to intermediate usage of code and controls. One of the difficulties I’ve faced in using publicly available samples is the “version-itis” problem. If I’m using an Express Edition instead of an Enterprise edition, or VS2010 instead of VS2012, things just don’t behave the same way (although sometimes, in theory, they should). So I think the most important thing for any “how-to” type of article is to get everyone on the same page, using the same tools. For this test run, I’ll be using:

  • Visual Studio Community 2013 Edition version: 12.0.31101.00
  • .NET version: 4.5.51650
  • Microsoft Excel 2013 (15.0.4693.1000) MSO (15.0.4693.1001) 32-bit (Part of Microsoft Office 365)

The VS 2013 Community Edition is free so there’s no financial impediment to installing the same version I have. For about $10 a month, you can sign up for Office 365 which gains you access to the web versions of Excel, Word, etc., and also allows you to install the desktop edition of Excel 2013. That’s the least expensive way to get on the same page. Note: In future examples, I’ll be using Microsoft SQL Server 2012, the free “Express” edition, but we’ll cross that bridge when we come to it).

Your version of .NET and Office may be slightly different depending on how religious you are about installing updates, but the top-level .NET version should be 4.5 and the Office version must be 2013 (15.xxx). The Visual Studio Community 2013 Edition version should be very close to identical and you must have the following extension installed:

* Microsoft Office Developer Tools for Visual Studio 2013 (November 2014 Update).

I’m currently running on Windows 8.1, but I don’t think that matters at all for purposes of this demonstration, because I’ve run the exact same thing on Windows 7 and Excel 2013 and the results are identical.

I prefer VB and will be using it for this example. If you prefer C#, hopefully you’ll be able to follow along, substituting the C# equivalents as necessary.

Once you’re sure that everything listed above is installed properly, proceed to the following simple example to confirm that everything is working properly.

1. Create new project. Visual Basic… Office/Sharepoint… Office Add-ins… Excel 2013 Add-in. I de-select the option to “Create Directory for solution” (want to keep the folder structure simple and there will be no additional projects added), and name the project “ReadyPrimeTime1”.

Create New VSTO Project

Create New VSTO Project

Your should see a new project containing a code file named “ThisAddIn.vb”. This is the only file we need to be concerned about right now, and we will leave it named as is. Your project and IDE work space should look something like this now:

VSTO Project after initial creation.

VSTO Project after initial creation.

2. Create a new Ribbon item for our add-in. We’re going to have a custom tab appear on the Ribbon and the tab will contain custom ribbon buttons and other controls. So, add a new Ribbon (Visual Designer) item to the project and name it “RibbonManager.vb”.

Add New Ribbon (Visual Designer) item

Add New Ribbon (Visual Designer) item

After the new designer is added, you should see a ribbon template appear, ready for your customizations.

Ribbon designer created and ready for edits

Ribbon designer created and ready for edits.

3. Select the new Tab by clicking where it says “TabAddIns (Built-In)” and let’s change some properties by selecting the control/item and using the Properties window:

  • Change the “(Name)” property to tabMain
  • Change the “Label” property to Our Add-in Tab.

4. Select the new Ribbon Group control by clicking where it says “Group 1”:

  • Change the “(Name)” property to “rgpFirst”.
  • Change the “Label” property to “First Group”.

5. Open the Toolbox and you should see a bunch of controls under the heading of Office Ribbon Controls. Select the ToggleButton and drag it on to “First Group”. Change the following properties:

  • Change the “(Name)” property to “tgbPane1”.
  • Change the “Label” property to “Show Pane #1”.
All Ribbon Properties Set

All Ribbon Properties Set

Save all files in the Project now before proceeding to the next step.

6. Next, we’re going to create a TaskPane that will appear along side the worksheet and will allow the user to interact with the worksheet using the controls on the TaskPane. TaskPanes are created as UserControls in VSTO. Let’s add a new UserControl object to the project and name it “FirstPaneTester.vb”.

Add UserControl for TaskPane

Add UserControl for TaskPane

Change the “Width” property of the new UserControl to “550” and the “Height” to “400”. I’m changing the height here just to make some room to place controls on the UserControl. When the program runs, the Height won’t really matter because we will be “docking” it on the left side, causing the control to fill the height of the screen. (Strangely, many of the properties, like “DockPosition”, are not available in design mode and must be set at run time).

Next, add the following standard Windows Forms controls to the UserControl and set properties:

  • Label – (Name) = “lblTitle”, Autosize = “False”, BackColor = “Black”, ForeColor = “White”, Location = “0, 0”, Width = “550”, Font Size = “12”, TextAlign = “MiddleCenter”, Text = “First Pane Test”
  • Label – (Name) = “lblSelect”, Text = “Select Message:”, Location = “40, 50”
  • ComboBox – (Name) = “cboMessage”, Location = “160, 50”, Width = “375”, Items = (see graphic below for items to manually add)
  • Button – (Name) = “btnSendMessage”, Location = “335, 90”, Width = “200”, Text = “Send Message to Sheet”
Manually entered ComboBox items

Manually entered ComboBox items using the “Items” property

Save everything now. We’ll come back to this UserControl shortly to write some code, but for now let’s return to the main Add-in module.

7. Open the “ThisAddin.vb” code module and add the following module-level variables:

'Create a new instance of our custom task pane.
Private m_tkpFirst As FirstPaneTester
'Create another custom take pane object that will handle events.
Private WithEvents m_tkpFirstValue As Microsoft.Office.Tools.CustomTaskPane

Next, add the code that will run when the Add-in is first started, or attached, to Excel. It should be entered in the ThisAddIn_Startup event block. See the code comments for details of what each line is doing.

Private Sub ThisAddIn_Startup() Handles Me.Startup
'Set the initial task pane variables and settings.

'Create a new instance of our First Task Pane object
m_tkpFirst = New FirstPaneTester()

'Add the new custom task pane instance to the Add-in's CustomTaskPanes collection.
m_tkpFirstValue = Me.CustomTaskPanes.Add(m_tkpFirst, "First Task Pane")

'Set initial visual properties of the new task pane
With m_tkpFirstValue
.DockPosition = Microsoft.Office.Core.MsoCTPDockPosition.msoCTPDockPositionLeft
.Width = 550
.Visible = False
End With

End Sub

Next, we must write code to handle the “VisibleChanged” event of the custom task pane object. Since we defined this object with “WithEvents”, we can handle any events that it raises. The important one we’re concerned with is the “VisibleChanged” event. This code will demonstrate how the action on the custom task pane can trigger a change on the Ribbon.

Private Sub m_tkpFirstValue_VisibleChanged(sender As Object, e As EventArgs) Handles m_tkpFirstValue.VisibleChanged

'Change the state of the Toggle Button on the ribbon to reflect the current Visibility
'of the custom task pane.
'Note: The reason we defined the m_tkpFirstValue object "WithEvents" is so we could
'capture events like this.
Globals.Ribbons.RibbonManager.tgbPane1.Checked = m_tkpFirstValue.Visible

End Sub

Code to handle raised VisibleChanged event

Code to handle raised VisibleChanged event

The last thing we want to do in the ThisAddIn.vb code module is add a Property so that external routines can create an instance of our custom task pane. It’s a read-only property so we don’t have to worry about creating a module-level instance to track state. And we don’t have to create a corresponding “Set” property.

Public ReadOnly Property FirstTaskPane() As Microsoft.Office.Tools.CustomTaskPane
'Return an instance of the "WithEvents" custom task pane variable to
'external calling routines.
Return m_tkpFirstValue
End Get
End Property

8. Open the “RibbonManager.vb” code module and add the following code:

Private Sub tgbPane1_Click(sender As Object, e As RibbonControlEventArgs) Handles tgbPane1.Click

'Change the Visibility state of the Custom Task Pane when the toggle
'button on the ribbon is clicked.
Globals.ThisAddIn.FirstTaskPane.Visible = TryCast(sender, RibbonToggleButton).Checked

End Sub

9. Finally, what to do when the user clicks the Button on the custom task pane (UserControl)? Let’s write the code to transfer the text in the ComboBox to the active worksheet. Open up the “FirstPaneTester.vb [Design]” window and double-click the “Send Message to Sheet” command button to open the code-behind window. Write the following code in the btnSendMessage_Click code block that is created:

Private Sub btnSendMessage_Click(sender As Object, e As EventArgs) Handles btnSendMessage.Click

'If a valid message has been selected from the ComboBox then update the worksheet.
If cboMessage.SelectedIndex = -1 Then
MessageBox.Show("You must select a message from the ComboBox first!")
Exit Sub
'Create a worksheet object (ws) for the current "Active" worksheet,
' and copy the text from the ComboBox to the B3 cell.
Dim ws As Excel.Worksheet = Globals.ThisAddIn.Application.ActiveSheet
ws.Range("B3").Value = cboMessage.Text
End If

End Sub

Troubleshooting Tips:

  1. If you have trouble with the “MessageBox.Show” method, make sure you have a reference to System.Windows.Forms library by placing a “Imports System.Windows.Forms” as the very first line of the FirstPaneTest.vb code module.
  2. If you have trouble with the Excel.Worksheet reference, make sure that your project has a reference to the Excel InterOp assembly. On the main menu, click “Project”… “Add Reference…”. When the references window opens, expand “Assemblies” and click “Extensions”. Scroll down to make sure that Microsoft.Office.Interop.Excel is checked.
  3. If the new custom Task Pane will simply not appear when you click the toggle button, then it’s almost certainly a conflict of some type with another Add-in. Disable all other Add-ins and try it again and it should work. On one of my computers, the “RibbonX Visual Designer” add-in was the culprit. I did some Bing searches on the Microsoft sites and found others saying that Microsoft’s own Analysis Toolpak add-in was causing the conflict. In any case, just disable them all and this add-in should work.

10. Now, save everything and try to Build the project (Build… Build Solution). If you do not receive any errors, go ahead and run the project by clicking the “Start” button on the toolbar or by pressing the “F5” key.

If all goes well, you should see Excel open up and wait for you to select a worksheet. Select the blank (empty) worksheet template.

You should now see the new tab titled “OUR ADD-IN TAB”. Click it and you will see the “First Group” ribbon group containing the “Show Pane #1” toggle button.

The new add-in appears on the Excel ribbon

The new add-in appears on the Excel ribbon.

11. Click the “Show Pane #1” toggle button on the ribbon and you should see our custom task pane appear.

New TaskPane with controls.

New TaskPane with controls.

Select one of the three messages fro the ComboBox, then click the “Send Message to Sheet” button to watch the magic happen! Unfortunately, all that’s going to happen is that our code will write the selected message to cell B3 on the worksheet. I know it seems a lot of work to perform such a menial task, but we’ve now laid the groundwork for expanding and enhancing our application.

If you click the “Show Pane #1” toggle button again, the custom task pane will be hidden. Click it again to show the task pane again.

VB code in task pane writes text out to worksheet cell B3.

VB code in task pane writes text out to worksheet cell B3.

One more important tip: Once you run the program, that new tab will remain present in Excel. Even after you close Visual Studio, the next time you open Excel, the add-in will still be there. In order to “clean up” after running the program you must go to the main Visual Studio menu (with our project still open) and click “Build”… “Clean Solution”. If that clean operation succeeds, the Add-in will be completely detached and removed from Excel.

The syntax for interacting with Excel in older VSTO versions was pretty wordy and complicated, which is what scared me off initially. But now, it appears to be almost as simple as coding in VBA… but now with the full power of Visual Studio behind it.

I think it’s possible that VSTO may indeed be ready for “prime time”, but we’ll have to continue our journey a bit farther before we can make such an assertion. The problem with conflicting add-ins (see “Troubleshooting Tips”, above) can be a real showstopper. You can’t simply tell clients that they need to disable all their add-ins so that yours will work!

I’ll try to put out one new article each month but, in the meantime, please let me know what your own experimenting uncovers.


Read Full Post »

You can only use the Redim Preserve statement to resize the last dimension of a multidimensional array, but there are many times you’ll need to resize the first dimension. The following function uses built-in Excel worksheet function “Transpose” to work around this limitation:

Public Sub ArrayResize1stDim(ArrayToResize As Variant, NewDim As Long)
'Allow the 1st dimension of the passed array to be resized.
' ArrayToResize = The array to be resized (must be passed ByRef)
' NewDim = The total number of elements desired in the
' 1st dimension of the resized array.
Dim lngOrigCols As Long

lngOrigCols = UBound(ArrayToResize, 2)

ArrayToResize = Application.Transpose(ArrayToResize)
ReDim Preserve ArrayToResize(1 To lngOrigCols, 1 To NewDim)
ArrayToResize = Application.Transpose(ArrayToResize)

End Sub

(Note: Due to the usage of Application.Transpose this function will only work with Excel VBA)

Read Full Post »

Don’t know if this will ever be needed again, but it was useful to me once, so I pass it along…

The following code loops through every file in a specified folder and prints every PDF that it finds:

'Use of FileSystemObject requires a reference to "Microsoft Scripting Runtime"
Dim objFSO As Scripting.FileSystemObject
Dim objFld As Scripting.Folder
Dim objFil As Scripting.file

'The ADOBE_PATH constant assumes a Win7 PC; your actual location may be different
Const ADOBE_PATH As String = "C:\Program Files (x86)\Adobe\Reader 9.0\Reader\AcroRd32.exe"
Const FILE_PATH As String = "C:\MyInvoiceFolder\"
Const FILE_EXT As String = "PDF"

Set objFSO = New Scripting.FileSystemObject
Set objFld = objFSO.GetFolder(FILE_PATH)

'Loop through each file in C:MyInvoiceFolder
For Each objFil In objFld.Files

If UCase$(Right$(objFil.Name, 3)) = FILE_EXT Then  'Only process PDFs

Application.StatusBar = "Printing Invoice file: " & objFil.Name

Shell """" & ADOBE_PATH & """/a /p /h """ & objFil.Path & """"

End If

Next objFil

'Clean up

Set objFil = Nothing
Set objFld = Nothing
Set objFSO = Nothing

Read Full Post »

Don’t Forget the RegEx

String manipulation and parsing tasks are just as common in Excel/VBA development as they are in apps developed in any other programming language. C, C# and C++ have powerful built-in string classes that greatly reduce the amount of code that must be written to accomplish these tasks. While VBA string manipulation code will always be more “wordy” than it’s C++ counterparts, there’s no reason that it has to be any less capable or powerful.

The task at hand was to write a utility that would parse lines in a CSV file. However, commas that appeared inside quotation marks should be ignored. For example, the string A,B,C,”D,E”,F,”G,H,I”,J,K, should be split into 8 elements:

Many beginner to intermediate VBA programmers may not be aware that Microsoft provides a powerful regex component that can be integrated into any Excel/VBA project. As soon as I understood the dimensions of the task, I immediately thought of Microsoft’s RegEx component. I’m sure there are many ways of doing this, but I think the RegEx object provides the most efficient method. Let’s get right to it.

Using RegEx in Excel/VBA

1. Start a new Excel workbook, open the VBA editor, and add a reference to “Microsoft VBScript Regular Expressions 5.5” (the current version as of this writing).

2. Add an ActiveX command button to the worksheet, name it “btnShowForm”, and change the Caption to “Show Regex Form”.

3. Back in the VBA editor, insert a new UserForm into the project, name it “frmParse”, and change the Caption to “Parse Special”.

4. Add the following controls to the new UserForm: one Label named “lblInput” (Caption = “String to Parse”), one Textbox named “txtInput”, one Listbox named “lstOutput” and two Command Buttons. The first command button should be named “btnParse” (Caption = “Parse”) and the second button should be named “btnExit” (Caption = “Exit”).

Your UserForm should look something like this:

New UserForm

New UserForm

5. Next, add the following code to the btnExit_Click event:


6. Next, add the following code to the btnParse_Click event (don’t worry, we’ll create the clsRegEx class module next):

Dim arrData() As String
Dim intWord As Integer
Dim objRegex As clsRegex

Set objRegex = New clsRegex
arrData = Split(objRegex.RegexParse(txtInput.Text), ",")
For intWord = 0 To UBound(arrData)
lstOutput.AddItem Replace(arrData(intWord), "?", ",")
Next intWord

Set objRegex = Nothing

7. Next, add a new Class module to the project, name it “clsRegex” and add the following function to the new class:

Public Function RegexParse(ByVal ToParse As String) As String
'Use regular expressions to find and replace quoted text in the CSV input.
'NOTE: Must add a reference to "Microsoft VBScript Regular Expressions 5.5".
Dim strPat As String, strReturn As String
Dim objRegExp As VBScript_RegExp_55.RegExp
Dim objMatch As VBScript_RegExp_55.Match

On Error GoTo RPError

strReturn = ToParse

If InStr(ToParse, Chr$(34)) > 0 Then
Set objRegExp = New VBScript_RegExp_55.RegExp
With objRegExp
.IgnoreCase = True
.Global = True 'Identify ALL instances that match regex pattern, not just first one.

        'NOTE: "[^"]+" regex code means "Match a double quote, match one or more chars that
        ' are not double quotes, then match a second double quote".
strPat = Chr$(34) & "[^" & Chr$(34) & "]+" & Chr$(34)
.Pattern = strPat
End With

For Each objMatch In objRegExp.Execute(strReturn)
strReturn = Replace(strReturn, objMatch.Value, _
Replace(Replace(objMatch.Value, Chr$(34), vbNullString), ",", "?"))
Next objMatch
End If

RegexParse = strReturn
Set objMatch = Nothing
Set objRegExp = Nothing
Exit Function

MsgBox "Error: " & Err.Number & vbCrLf & vbCrLf & "Description: " & _
Err.Description, vbCritical, "Regex Parsing Error"
strReturn = ToParse 'Set the return value back to the original string
Resume RPResume

End Function

8. Finally, go back to the worksheet and add the following code to the cmdShowForm_Click event:

frmParse.Show vbModal
Unload frmParse

That’s it for the coding. Now save and open your new workbook. Click the “Show Form” button on the worksheet. After the UserForm appears, enter the following in the input text box:


Click the “Parse” button and you should see the Listbox fill with eight rows. The string in the text box should be broken out exactly as required.

RegEx form with Listbox filled

RegEx form with Listbox filled

Notice the way the “RegExp” and “Match” classes of the VBScript_RegExp_55 module are used to accomplish the task. What actually happens is that the RegExp module is used to identify the pattern where a comma appears within quotation marks. It then changes those quotes to question marks, so the calling routine (cmdParse_Click) can use the Split function to push the CSV line into an array correctly. The btnParse code then switches the question marks back to commas before outputting the data to the Listbox.

So, don’t forget the “RegEx” the next time you’re faced with a pattern-matching problem.

Read Full Post »

Build a custom data access class that you can plug into any Excel application that requires Microsoft SQL Server or Microsoft Access connectivity. This will require two code modules: a class module and a standard module. The standard module is used simply to house the global database class instance, and to create/destroy it when the application workbook opens/closes.

Let’s get right into the code. First create a new workbook and switch to the VBA Editor. Add a reference to “Microsoft ActiveX Data Objects 2.8 Library”. Create a new Class module and name it “clsSQLConnection”. Add the following code to this class module.

clsSQLConnection Code

Option Explicit

'Module-level objects
Private mobjConn As ADODB.Connection
'Module-level variables
Private mblnIntegratedSecurity As Boolean
Private mstrModuleName As String
Private mstrConnectionString As String
Private mstrCurrentServer As String
Private mstrCurrentDatabase As String
Private mstrDatabaseType As String

Private Sub Class_Initialize()
mstrModuleName = "clsSQLConnection"
Set mobjConn = New ADODB.Connection
End Sub

Private Sub Class_Terminate()
On Error Resume Next
Set mobjConn = Nothing
On Error Goto 0
End Sub

Public Property Get ConnectionString() As String
ConnectionString = mstrConnectionString
End Property

Public Property Let ConnectionString(ByVal NewValue As String)
mstrConnectionString = NewValue
End Property

Public Property Get CommandTimeOut() As Integer
    CommandTimeOut = mobjConn.CommandTimeOut
End Property

Public Property Let CommandTimeOut(ByVal NewTimeOut As Integer)
mobjConn.CommandTimeOut = NewTimeOut
End Property

Public Property Get CurrentDatabase() As Integer
'Read-only property
CurrentDatabase = mstrCurrentDatabase
End Property

Public Property Get CurrentServer() As String
'Read-only property
CurrentServer = mstrCurrentServer
End Property

Public Property Get DatabaseType() As String
DatabaseType = mstrDatabaseType
End Property

Public Property Let DatabaseType(ByVal NewValue As String)
mstrDatabaseType = NewValue
End Property

Public Property Get IntegratedSecurity() As Boolean
IntegratedSecurity = mblnIntegratedSecurity
End Property

Public Property Let IntegratedSecurity(ByVal NewValue As Boolean)
mblnIntegratedSecurity = NewValue
End Property

Public Sub CloseDB()
'Close connection to database.

On Error Resume Next
If Not mobjConn Is Nothing Then
If mobjConn.State And adStateOpen Then
'Connection is defined and still open; close it.
End If
End If
On Error GoTo 0

End Sub

Public Sub ShowErrorMessages(ByVal StandardErrorObject As VBA.ErrObject, _
ByVal SourceModule As String, ByVal SourceMethod As String)
'Construct a comprehensive error message based on the passed objects.
Dim strMsg As String

'Handle the standard error, if any.
If StandardErrorObject.Number < > 0 Then
strMsg = "Error: " & CStr(Err.Number) & vbCrLf & vbCrlf & "Description: " & _
Err.Description & vbCrLf & vbCrLf
End If

'Include the database-related errors, if any.
If Not (gobjDB Is Nothing) Then
strMsg = strMsg & gobjDB.ADOErrors()
End If

'Finally, tack on the module/method names.
strMsg = strMsg & SourceModule & "::" & SourceMethod & vbCrLf


MsgBox strMsg, vbCritical, "Contact Technical Support For Assistance"

End Sub

Public Function ADOErrors() As String
'Return a fully formatted string containing any current ADO errors in the collection.
Dim lngCount As Long
Dim objErr as ADODB.Error
Dim strReturn As String

strReturn = vbNullString

For Each objErr in mobjConn.Errors
strReturn = strReturn & CStr(objErr.Number) _
& vbCrLf & objErr.Description & vbCrLf & vbCrLf
Next objErr

ADOErrors = strReturn

End Function

Public Function OpenDB(Optional ByVal DatabaseType As String, _
Optional ByVal TargetServer As String = "", _
Optional ByVal TargetDatabase As String = "", _
Optional ByVal IntegratedSecurity As Boolean = False) As Boolean
'Open a connection to the specified server and database, if not already open.
'If the parameters are not specified, then just re-use the last connection
' string that was created.

Dim blnNewConnect As Boolean, blnReturn As Boolean
Dim strDataSource As String
Dim strDB As String
Dim strConn As String

blnReturn = True
blnNewConnect = True

On Error GoTo ODError

If Not mobjConn Is Nothing Then
If mobjConn.State And adStateOpen Then
'Connection is alread defined and opened.
blnNewConnect = False
End If
End If

If blnNewConnect Then
'Must create a new connection
If TargetServer = "" Or TargetDatabase = "" Then
'Calling routine has not specified Server or Database values;
' default to last used.

If Len(mstrConnectionString) > 0 Then
strConn = mstrConnectionString
'If full connection string is blank, use the individual Server/Environment and
' Database variables to determine connection.

strConn = BuildConnectionString(mstrDatabaseType, mstrCurrentServer, _
mstrCurrentDatabase, mblnIntegratedSecurity)
End If
'Build connection string, based on passed arguments
strConn = BuildConnectionString(DatabaseType, TargetServer, TargetDatabase, _
End If
mobjConn.ConnectionString = strConn
End If

OpenDB = blnReturn
Exit Function

blnReturn = False
ShowErrorMessages Err, mstrModuleName, "OpenDB"
Resume ODResume

End Function

Public Function BuildConnectionString(ByVal DatabaseType As String, _
ByVal TargetServer As String, _
ByVal TargetDatabase As String, _
ByVal IntegratedSecurity As Boolean, _
Optional ByVal UserID As String, _
Optional ByVal Password As String) As String
'Construct a full connection string, set local properties, and
' return string to calling routine.

'Build connection string
Select Case DatabaseType
Case "SQLServer"
'Microsoft SQL Server; use proper network library.
mstrConnectionString = "Network Library=DBMSSOCN;" & _
";INITIAL CATALOG=" & TargetDatabase & _
If IntegratedSecurity Then
mstrConnectionString = "Provider=SQLNCLI10;" & _
"Server=" & TargetServer & ";" & _
"Database=" & TargetDatabase & ";" & _
End If
Case "Access2003"
'Access 2003 and prior
mstrConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.Path & "\" & _
TargetDatabase & ".mdb;"
Case "Access2007"
'Access 2007 or 2010
mstrConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.Path & "\" & _
TargetDatabase & ".accdb;Persist Security Info=Flase;"
Case Else
'Some other server; modify to accommodate.
mstrConnectionString = "Provider=SQLNCLI10;Server=" & TargetServer & _
";Database=" & TargetDatabase & ";Trusted_Connection=yes;"
End Select

'Update the module variables
mstrCurrentServer = TargetServer
mstrCurrentDatabase = TargetDatabase
mblnIntegratedSecurity = IntegratedSecurity

BuildConnectionString = mstrConnectionString

End Function

Public Function ExecuteSPWithADOCommand(StoredProcName As String, _
OutputParameter As String, OutputValue As Variant, _
ParamArray InputParameters() As Variant) As Boolean
'Execute a stored procedure, using an ADO command object. The InputParameters
' paramarray must contain pairs of data (i.e. element 0 should be Parameter name,
' with leading '@', and element 1 should be the associated parameter value; then
' element 2 is the next parameter name, element 3 is the next parameter value, etc.).
' Also allows for a single Output parameter and associated return value
' (OutputParmeter and OutputValue ByRef parameters). Remember
' to prefix the OutputParmeter name with '@', same as the input parameters.

Dim objCmd As ADODB.Command
Dim blnReturn As Boolean
Dim intParam As Integer
Dim strParamName As String
Dim vntParamValue As Variant

blnReturn = True

On Error GoTo ESPError

If OpenDB() Then
Set objCmd = New ADODB.Command
With objCmd
.ActiveConnection = mobjConn
.CommandText = StoredProcName
.CommandType = adCmdStoredProc
'Define the Input Parameters
For intParam = 0 To UBound(InputParameters) Step 2
.Parameters(InputParameters(intParam)).Value = _
InputParameters(intParam + 1)
Next intParam
'Define the single allowed output parameter, if any
If Len(Trim(OutputParameter)) > 0 Then
.Parameters(OutputParameter).Direction = adParamOutput
End If
'Execute the stored procedure
End With

'Retrieve the value of the output parameter (if any)
If Len(Trim(OutputParameter)) > 0 Then
OutputValue = objCmd.Parameters(OutputParameter).Value
OutputValue = vbNullString
End If
'No database connection could be established, but no error
' was raised (should never happen).

OutputValue = vbNullString
blnReturn = False
End If

ExecuteSPWithADOCommand = blnReturn
Set objCmd = Nothing
Exit Function

blnReturn = False
ShowErrorMessages Err, mstrModuleName, "ExecuteSPWithADOCommand"
Resume ESPResume

End Function

Function GetRecordset(strSQL As String) As ADODB.Recordset
'Return a disconnected recordset from the database.
Dim rst As ADODB.Recordset

On Error GoTo GRError

If OpenDB() Then
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseClient
rst.Open strSQL, mobjConn, adOpenDynamic

Set GetRecordset = rst
rst.ActiveConnection = Nothing
End If

Exit Function

ShowErrorMessages Err, mstrModuleName, "GetRecordset"
Resume GRResume

End Function

Public Function GetRecordsetToArray(strSQL As String) As Variant
'Return recordset data into an array. If, for any reason, the recordset
' does not return any data, this function simply creates a single element
' array and populates it with "No matching records...".

Dim rst As ADODB.Recordset
Dim arrData As Variant
Dim lngX As Long

On Error GoTo GRAError

If OpenDB() Then
Set rst = New ADODB.Recordset
With rst
.CursorLocation = adUseClient
.LockType = adLockReadOnly
.Open strSQL, mobjConn, adOpenStatic

If Not (rst.EOF) Then
'Disconnect the recordset
.ActiveConnection = Nothing
'Get the field count
lngX = .Fields.Count
arrData = .GetRows()
'Recordset is empty; create dummy array record
ReDim arrData(0, 0)
arrData(0, 0) = "No matching records found in the database"
End If
End With
'Connection failed for some reason; in order not to crash the
' calling routine, create dummy array record.

ReDim arrData(0, 0)
arrData(0, 0) = "Could not open database connection"
End If

GetRecordsetToArray = arrData
Exit Function

ShowErrorMessages Err, mstrModuleName, "GetRecordsetToArray"
Resume GRAResume

End Function

Public Function GetMultipleRecordsets(strSQL As String) As ADODB.Recordset
'Allows for multiple recordsets to be returned to the calling routine.
'IMPORTANT - Although this method is similar to the GetRecordSet function,
' there are significant differences.
' 1. Do not disconnect the Recordset (i.e. don't set ActiveConnection to Nothing).
' 2. You must not close the database connection! It must remain open so that
' the calling routine can retrieve all of the resultsets in the returned Recordset.

Dim rst As ADODB.Recordset

On Error GoTo GMRError

If OpenDB() Then
Set rst = New ADODB.Recordset
rst.Open strSQL, mobjConn

Set GetMultipleRecordsets = rst
End If

'REMEMBER! Do NOT close the connection here. Calling routine must close it.
Exit Function

ShowErrorMessages Err, mstrModuleName, "GetMultipleRecordsets"
Resume GMRResume

End Function

Public Function ExecuteActionQuery(SQLToExecute As String) As Boolean
'Execute an action query, or stored procedure, which is not expected
' to return a resultset.

Dim blnReturn As Boolean

blnReturn = True

On Error GoTo EAQError

If OpenDB() Then
mobjConn.Execute SQLToExecute
End If

ExecuteActionQuery = blnReturn
Exit Function

blnReturn = False
ShowErrorMessages Err, mstrModuleName, "ExecuteActionQuery"
Resume EAQResume

End Function

Public Property Get SQLConnection() As ADODB.Connection
'Return the actual connection object, if requested by
' calling routine.

If Not mobjConn Is Nothing Then
On Error Resume Next
Set SQLConnection = mobjConn
On Error GoTo 0
End If

End Property

modGlobal Code

Next, insert a new standard module, name it modGlobal and copy the following code:

Option Explicit

'Global data access class object
Public gobjDB As clsSQLConnection

Public Sub InitializeDatabase()
Dim strDatabaseType As String
Dim strServerName As String
Dim strDatabaseName As String
Dim blnIntegratedSecurity As Boolean
Dim strUserID As String
Dim strPassword As String

'*** NOTE: The database properties and user ID, etc. can be read from an
' INI file or some other source. For this example, just hard-code
' the server and database values and assume that Windows integrated
' security is being used (so no UID or Pwd are required).
' This procedure assumes that you have a local SQL Server
' installation, with a database named "MyDatabase".
' Modify this as necessary to conform to your test environment.

strDatabaseType = "SQLServer"
strServerName = "(local)"
strDatabaseName = "MyDatabase"
blnIntegratedSecurity = True

Set gobjDB = New clsSQLConnection
gobjDB.BuildConnectionString strDatabaseType, strServerName, _
strDatabaseName, blnIntegratedSecurity

End Sub

Public Sub DestroyDatabase()

If Not (gobjDB Is Nothing) Then
On Error Resume Next
Set gobjDB = Nothing
End If

End Sub

Public Sub TestDataAccess()
'Test everything to make sure it works.
'NOTE: This procedure assumes there is a database
' table named "MyTestTable" that has at least two
' fields: "Field1" and "Field2". Modify to match
' your specifics.

Dim rsTest As ADODB.RecordSet
Dim lngRow As Long

Set rsTest = gobjDB.GetRecordSet("SELECT * FROM MyTestTable")
If Not (rsTest Is Nothing) Then
If Not rsTest.EOF Then
lngRow = 1
Do While Not rsTest.EOF
ActiveSheet.Range("A" & lngRow).Value = rsTest("Field1").Value
ActiveSheet.Range("B" & lngRow).Value = rsTest("Field2").Value
lngRow = lngRow + 1
End If
End If

End Sub

Workbook Code

Finally, in order to have the database connection initialized when the workbook opens, and destroyed when the workbook closes, add the following code to the “ThisWorkbook” object:

Option Explicit

Private Sub Workbook_Open()
InitializeDatabase 'Make call to global subroutine.
End Sub

Private Sub Workbook_BeforeClose()
End Sub

IMPORTANT: Remember that you must change the property values in the InitializeDatabase function to match your SQL Server values, and you must modify the table and field names for your test query in the TestDataAccess subroutine

That’s all you need to have a fully functional set of database access routines that can be plugged into any Excel workbook. Of course, there’s more functionality that can be added to the clsSQLConnection class module, such as application-specific stored procedure calls, database transaction management, etc. Use this as a starting point for your work, and modify as needed.


Read Full Post »

After taking over maintenance of an Excel application, the first problem I encountered was that the app was extremely “Pivot Table Heavy”. The original developer needed to take snapshots of a data set, sliced and diced almost 50 different ways (49, to be exact). He accomplished this by creating 49 Pivot Tables on a worksheet, and then having the main report tables (on another worksheet) reference each of these Pivot Tables. I just didn’t know where to begin pointing out the wrong-ness of this whole approach. The immediate problem was that yet another report table was being added, thus necessitating the addition of yet another Pivot Table. But we found that any modifications made to the existing Pivot Table worksheet would cause the application to crash. There was no time to re-write the entire application from scratch.

My first thought was to whittle the data worksheet down to just ONE Pivot Table. The Pivot Table filters could be manipulated in VBA code and a snapshot created after each filter refresh, copying the data to the same location as the current 49 Pivot Tables. This would eliminate the need to change anything on the main reporting worksheet because those tables would still reference the exact same locations where the 49 Pivot Tables were except now it would not be 49 Pivot Tables, but 49 standard data ranges that had been copied from the “master” Pivot Table. Thus making the workbook less “Pivot Table Heavy” and hopefully more stable.

I could handle writing the code to manipulate the filters, etc., using VBA without a problem, but I needed a clean way to copy just the column headers, row labels and data from the Pivot Table (i.e. NOT the page or report filters). So, what is the best way, using VBA, to read all of the visible data in a Pivot Table? I needed to just be able to grab all the data I wanted from the Pivot Table and copy it somewhere else. There could be 1 row or 1,000 rows in the pivot table. In either case, I just want to grab it all and copy it. The GetPivotData function provides copying on a cell by cell basis and so was unsuitable for this application.

After some experimentation, I discovered the TableRange1 method of the PivotTable object.

Let’s begin by creating a new macro-enabled workbook and call it PivotCopyTest.xlsm.

Rename “Sheet1” to “Stores“, and populate it with the following test data, borrowed from a Microsoft “Contoso” test database. (Note that this is an admittedly dopey example, and not the data I was actually working with, but it’s sufficient to demonstrate the main point of this post):


Raw Data

Source Data for Pivot Table

Next, create a Pivot Table on a new worksheet as follows (Excel 2010 instructions; if you’re using 2007, this may differ slightly):

1. Select one of the cells in the source data table.

2. Click on the “Insert” ribbon tab, then click the “PivotTable” button. This will bring up the CreatePivotTable dialog box. Make sure that the selection range is specified properly, and that the Pivot Table will be created on a “New Worksheet”. Click the “OK” button to create the Pivot Table.

Pivot Table Creation Dialog

Pivot Table Creation Dialog

3. Pivot Table should be defined as follows:

  • Report Filter = GeographyKey
  • Column Labels = StoreType
  • Row Labels = StoreName
  • Values = Sum of Sales

The PivotTable Field list and final Pivot Table appearance are shown below:

Field Layout and Final Appearance

Field Layout and Final Appearance

Open the VBA Editor, insert a new Standard Module and add the following subroutine:

Public Sub SelectPivotData()
'Copy the column headers, row labels and data from a Pivot Table.
Dim pvtTest As PivotTable

Set pvtTest = Sheet1.PivotTables(1)
With pvtTest.TableRange1
    'Output the Address of the TableRange1 range, just to confirm that it's grabbing the data we want
    ActiveSheet.Range("G1") = .Address
    'Now copy the data to a new location
    .Copy Destination:=Range("G5")   
End With
End Sub

That’s all there is to it. Run this subroutine and you’ll see that this strips off the report field filters and leaves me with just the data I want.

For anyone who is interested, there is also a TableRange2 property which returns all of the visible rows in the pivot table, including the page/report fields. And, as I found out from Andy Pope (Microsoft guru), there is also a DataBodyRange property, which excludes column headers and row labels, leaving just the actual data values. Just substitute either of these values for the .TableRange1 in the code above to test them out.

Go figure. After many years working in Excel, I never heard of “TableRange1”, “TableRange2” or “DataBodyRange”.  Always an adventure…


Read Full Post »