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

, , , , , , , , ,

PeleFinal

Pele was an amazing soccer (futbol) player. I’m more of an American football fan myself – but I cannot deny the art, grace and class with which Pele played futbol. Pele is pictured here executing a bicycle kick against Belgium in 1968. Maybe what sets Pele and other sports stars apart from the rest is they too begin with the end in mind as suggested by Stephen Covey in The Seven Habits of Highly Effective People.

Today’s post, however, is not about futbol or the latest book being touted by business and leadership pundits. It is about the Goal Seek Method of the Range Object of the Excel Object Model.

Goal Seek

Goal2

Here is a sample formula to calculate Net Sales using 4 inputs: Average Check, Operating Days, Population and Participation. As you see displayed from FORMULATEXT() Function, the 4 inputs are simply multiplied together.


    The FORMULATEXT() function is one of the new functions introduced with Excel 2013. Check them all out here


We can use Goal Seek manually from the Ribbon. In Excel 2013:

Goal3

  1. Click on the Data Tab of the Ribbon
  2. Go to the Data Tools Group
  3. Click on What-If Analysis
  4. Click on Goal Seek

Goal4

I launched Goal Seek. I want to know what participation would need to be to achieve Net Sales of $10K?

Goal5

Holding all other inputs constant, I would need to increase participation from 14.32% to 16.83% to get to $10K in Net Sales. All well and good so far. But what if I need to find values for 12 different months? 52 Weeks? Some other Scenario with 100’s of desired outputs? Time for some VBA!

Goal Seek VBA

Goal6

I cannot find the Goal Seek Method listed as a Member of the Range Class in the Object Explorer in the VBA Editor?


  1. Press [Alt]+[F11] to launch the VBA Editor
  2. Once in the Editor, [F2] to launch the Object Explorer


Hmmm….I’ll check documentation on MSDN:


  1. Object model reference (Excel 2013 developer reference)
  2. Object model reference (Excel 2010 developer reference)
  3. Object model reference (Excel 2003 developer reference) – Compiled Help File


I checked the Developer Reference for Excel 2013 and Excel 2010. I could not find anything on Goal Seek. I downloaded the Excel 2003 Developed Reference as a compiled help file and finally found some documentation on the Goal Seek Method.

Goal7

Goal8

Here’s a quick little snippet I wrote. Even though Goal Seek does not show as a Method of the Range Object in Excel 2013, even though the Goal Seek Method is not documented in the Excel Developer Reference for Excel 2013, it will still work with Excel 2013.

This is not the first time I have seen this. I can’t recall what the last Object and Member were.

Goal Seek Method Requirements

For the Goal Seek Method to work, I must provide the following objects and values:

  1. A Range Object (Cell) that contains a formula
  2. A goal value
  3. And the changing Cell as a Range Object

Well, that makes sense, since the Goal Seek Dialog Box prompted me to manually select or enter those items earlier.

From the requirements list, I see that one strategy would be to use a loop with the .Cells() Property of the Worksheet Object as the Range Objects. With the Cells() Property, I need to pass a Row Index and a Column Index through each iteration of the loop.

The Setup…

Goal9

I added 11 months to the existing data and randomized the participation amounts. Now I would like to find what the participation would need to be for each of the 12 months to increase sales an additional $5K each month.

Goal10

Goal Seek Method…Fixed Range

Here is a basic Goal Seek Snippet that could be used with a fixed Range where the Worksheets and Range Objects are known and do not change:

Option Explicit

Sub SetGoal()

'----------------------------------------------------------------------
'Use Goal Seek Method of the Range Object with a dictator application
'----------------------------------------------------------------------
'Author     : Winston Snyder
'Date       : 3/30/2015
'Website    : http://dataprose.org/
'----------------------------------------------------------------------

    'Declare objects
        Dim wb As Workbook
        Dim ws As Worksheet
  
    'Declare constants
        Const lngROW_SEEK As Long = 4
        Const lngROW_GOAL As Long = 10
        Const lngROW_CHANGE As Long = 5
        Const lngCOL_BEGIN As Long = 6
        Const lngCOL_END As Long = 17
    
    'Declare variables
        Dim i As Long
    
    'Initialize
        Set wb = ThisWorkbook
        Set ws = wb.Worksheets("Sheet1")
    
    'Goal Seek
        With ws
            For i = lngCOL_BEGIN To lngCOL_END
                .Cells(lngROW_SEEK, i).GoalSeek _
                    Goal:=.Cells(lngROW_GOAL, i).Value, _
                    ChangingCell:=.Cells(lngROW_CHANGE, i)
            Next i
        End With
    
    'Tidy up
        Set ws = Nothing
        Set wb = Nothing
End Sub

Goal11

My Change Row was Row 5, “Participation”. Participation has been increased to the point needed to drive Net Sales on Row 4 to the target “New Sales” on Row 10.

All well and good, but what if I want to:

  1. Choose a different set of values pre-programmed values for the the Goal?
  2. Choose a different input/driver Row

I will need something a bit more flexible.

Goal Seek Method…Dynamic Options

One way to make the code snippet a bit more flexible, is to use a Type:=8 InputBox. The Type:=8 InputBox allows the user to select a Cell on a Worksheet. I first introduced this concept in this post on the LIKE Operator.


    More on Application.InputBox Method (Excel) here


I’ll create a Function and call it 3 times to prompt the user to select a cell that begins the Range for

  1. The Range that contains the formula that I am seeking a goal for.
  2. The Range that contains the target value
  3. The Range that contains an input that is to be be changed to arrive at the target value
Public Function GetUserCell(strPrompt As String) As Range
 
    'Declare variables
        Dim rng As Range
     
    'Users - select a cell on a worksheet
        Set rng = Application.InputBox( _
                    Prompt:=strPrompt, _
                    Title:="Select a Cell", _
                    Default:=ActiveCell.Address, _
                    Type:=8) 'Range selection
                     
    'Get the parent worksheet of the selected cell
        Set GetUserCell = rng
     
    'Tidy up
        Set rng = Nothing

 End Function

Now I can create a Sub(), call the function 3 times, and load my 5 variables based on the user selections.

The final dynamic Goal Seek Sub():

Option Explicit

Sub SetGoalDynamic()

'----------------------------------------------------------------------
'Use Goal Seek Method of the Range Object allow user to choose cells in range for:
'     The formula to be used in determining a solution
'     The goal value
'     An input cell that will be altered by Goal Seek to arrive at the desired solution
'----------------------------------------------------------------------
'Author     : Winston Snyder
'Date       : 3/30/2015
'Website    : http://dataprose.org/
'----------------------------------------------------------------------

    'Declare objects
        Dim wb As Workbook
        Dim ws As Worksheet
        Dim rngRowSeek As Range
        Dim rngRowGoal As Range
        Dim rngRowChange As Range
  
    'Declare constants
        Const strROW_SEEK As String = "Please select a cell in the row that contains the formula you will use for Goal Seek."
        Const strROW_GOAL As String = "Please select a cell in the row that contains the Goal Value that you are trying to find a solution for."
        Const strROW_CHANGE As String = "Please select a cell in the row that contains an input value for the formula."
    
    'Declare variables
        Dim lngRowSeek As Long
        Dim lngRowGoal As Long
        Dim lngRowChange As Long
        Dim lngColBegin As Long
        Dim lngColEnd As Long
        Dim i As Long
    
    'Initialize
        Set wb = ThisWorkbook
        Set ws = wb.Worksheets("Sheet1")
        
    'Get user inputs
        Set rngRowSeek = GetUserCell(strPrompt:=strROW_SEEK)
        Set rngRowGoal = GetUserCell(strPrompt:=strROW_GOAL)
        Set rngRowChange = GetUserCell(strPrompt:=strROW_CHANGE)
        
    'Get variable values from user inputs
        lngRowSeek = rngRowSeek.Row
        lngRowGoal = rngRowGoal.Row
        lngRowChange = rngRowChange.Row
        lngColBegin = rngRowSeek.End(xlToLeft).Column + 1 'Offset for labels
        lngColEnd = rngRowSeek.End(xlToRight).Column
    
    'Goal Seek
        With ws
            For i = lngColBegin To lngColEnd
                .Cells(lngRowSeek, i).GoalSeek _
                    Goal:=.Cells(lngRowGoal, i).Value, _
                    ChangingCell:=.Cells(lngRowChange, i)
            Next i
        End With
    
    'Tidy up
        Set rngRowSeek = Nothing
        Set rngRowGoal = Nothing
        Set rngRowChange = Nothing
        Set ws = Nothing
        Set wb = Nothing
        
End Sub

Tidy Up

That’s it for today, hopefully something helpful for you in this post. I use Goal Seek a bit when forecasting and budgeting and my supervisor asks me for some options to achieve certain desired targets or we get push back upstream.

How do you use Goal Seek?

Btw, as of today, Monday, March 30,2015, the first NFL Preseason game is only 132 days away. Sunday night, August 9, 2015. Hang in there!

, , , , , , , , , ,

CharlieBrownFinal

Here in the States – All Hallows’ Eve (Halloween) is quickly approaching. One of my favorite times of the year with leaves changing color, daylight getting shorter, a crispness in the air, football season is in full swing, and the Fall Classic (Major League Baseball) begins in a few weeks.

All Hallows’ Eve is a time for hobgobblery and apparitions of all sorts as with Charlie Brown and the Peanuts gang pictured here. Excel too has a ghost. In this post I’ll take a look at one and how we might put it to rest.

Worksheet UsedRange Property

The Worksheet Object has a UsedRange Property. Normally, we should be able to use this property so that we can quickly identify the entire UsedRange on the Worksheet without having to jump through a lot of hoops.

UsedRange1

Here is a Range of Cells with some data. We can quickly find the address of the UsedRange on the Worksheet:

Option Explicit

Sub GetUsedRangeAddress()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    
    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet
    Set rng = ws.UsedRange
    
    Debug.Print rng.Address
    
    Set rng = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub

Output:

$A$1:$J$10

Great – that is what I expected. But what happens if I delete some data?

UsedRange…False/Positive

A false positive occurs when we test for data and Excel tells us that there is data when in fact there is not.

UsedRange2

Here is the same data as before, but I deleted the data from Columns $H:$J. Now I’ll respin the code and check results:

$A$1:$J$10

Hmmm…same results – that is not good – therefore:


    we cannot rely on the UsedRange Property of the Worksheet Object. We need a better way to find the TRUE used range of data


The Last Used Cell

We can use the Find Method of the Range Object to get the last cell on the Worksheet that contains any data:

Sub GetLastCell()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    
    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet

    With ws
        Set rng = .Cells.Find(What:="*", _
                              After:=.Cells(1, 1), _
                              LookIn:=xlFormulas, _
                              LookAt:=xlPart, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False)
    End With
                                
    Debug.Print rng.Address
    
    Set rng = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub

Output:

$G$10

Great – that’s what I was looking for. What happens if there is nothing on the Worksheet? I moved to a new worksheet in the Workbook and tried the code again:

UsedRangeError1

That’s not good. I need to revise my code a bit to handle cases where there is no data on the worksheet:

Sub GetLastCellHandleNoData()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    
    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet

    With ws
        Set rng = .Cells.Find(What:="*", _
                              After:=.Cells(1, 1), _
                              LookIn:=xlFormulas, _
                              LookAt:=xlPart, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False)
    End With
    
    If Not rng Is Nothing Then
        Debug.Print rng.Address
    Else
        Debug.Print "There is no data on worksheet ", ws.Name
    End If
    
    Set rng = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub

I tested the code on a Worksheet with data in $A$1:$G$10. Results:

$G$10

Great – that’s what I expected.

Next I tested on a Worksheet with no data. Results:

There is no data on worksheet Sheet2

Great – that’s what I expected.


    I tested the code on a wide variety of scenarios for data placement on the Worksheet. It appears to work for any possible scenario. Please let me know if your tests return unexpected results or errors.


I now have the last used Cell on the Worksheet. Now I need the first used Cell on the Worksheet.

The First Used Cell

For the first used Cell, I tested Cell(1,1) first and then the remainder of the Worksheet. When data was in Cell $A$1, beginning at $A$1 and searching was returning the next Cell address.

Sub GetFirstCell()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    
    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet

    With ws
        If Not IsEmpty(ws.Cells(1, 1)) Then
            Set rng = ws.Cells(1, 1)
        Else
            Set rng = .Cells.Find(What:="*", _
                                  After:=.Cells(1, 1), _
                                  LookIn:=xlFormulas, _
                                  LookAt:=xlPart, _
                                  SearchOrder:=xlByRows, _
                                  SearchDirection:=xlNext, _
                                  MatchCase:=False)
        End If
    End With
    
    If Not rng Is Nothing Then
        Debug.Print rng.Address
    Else
        Debug.Print "There is no data on worksheet ", ws.Name
    End If
    
    Set rng = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub

Final Functions() and Subs()

The stuff above is fine, but it would be cool if we could develop a function to return the True Used Range. I developed a few Functions() and Subs() to that end.

Function..GetUserSelectedCell

I would like to prompt the user to select a cell and test if there is any data on the worksheets the cell is located on. This makes my code more efficient before I continue processing.

Here I am using the InputBox of the Application Object with Type 8 parameter to allow the user to select a cell for the InputBox. More on the Application.InputBox Method (Excel).

Public Function GetUserSelectedCell(strPrompt As String, _
                                    strTitle As String) As Range

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'GetUserSelectedCell
    'Returns a Range Object based on Cell user selects
    '
    'Parameters        :
    'strPrompt         :    A string variable.
    '                  :    Provide a question or statement to the user to take some action.
    'strTitle          :    A string variable.
    '                  :    Provide a title for the InputBox.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

     'Declare variables
        Dim rng                         As Range
        
    'Users - select a cell on a worksheet
        On Error Resume Next
        Set rng = Application.InputBox( _
                        Prompt:=strPrompt, _
                        Title:=strTitle, _
                        Default:=ActiveCell.Address, _
                        Type:=8) 'Range selection

        On Error GoTo 0
        
    'Activate the worksheet
        On Error Resume Next
        rng.Parent.Activate
        
    'Pass object to function
        Set GetUserSelectedCell = rng
     
    'Tidy up
        If Not rng Is Nothing Then Set rng = Nothing

 End Function

And here is how I call the Function in the final Sub()

    'Prompt user to select a cell on a worksheet
        Set rngUserCell = GetUserSelectedCell(strPrompt:="Please select a cell on a worksheet.", _
                                              strTitle:="Get Cell Selection From User")

Function..What if the user clicked cancel?

The user may choose to cancel at the InputBox, so we need to handle that possibility. In this Function() I am using a MsgBox to ask the user if they wish to try again. More on the MsgBox Function.

Public Function GetUserMessageResponse(strPrompt As String, _
                                       strTitle As String, _
                                       lngButtons As Long) As Long

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'GetUserMessageResponse
    'Returns a value as a Long DataType
    '
    'Parameters        :
    'strPrompt         :    Required. A string datatype.
    '                  :    Provide a question or statement to the user to take some action.
    'strTitle          :    A string datatype.
    '                  :    Provide a title for the InputBox.
    'lngButtons        :    A long datatype
    '                  :    Use one of the vba button type enumerations
    '                  :    vbOKOnly            0   OK button only                      <-Default value
    '                  :    vbOKCancel          1   OK and Cancel buttons
    '                  :    vbAbortRetryIgnore  2   Abort, Retry, and Ignore buttons
    '                  :    vbYesNoCancel       3   Yes, No, and Cancel buttons
    '                  :    vbYesNo             4   Yes and No buttons
    '                  :    vbRetryCancel       5   Retry and Cancel buttons
    'Information       :    The Message Box returns 1 of 7 values:
    '                  :    vbOK        1
    '                  :    vbCancel    2
    '                  :    vbAbort     3
    '                  :    vbRetry     4
    '                  :    vbIgnore    5
    '                  :    vbYes       6
    '                  :    vbNo        7
    '
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    'Declare variables
        Dim MsgBoxValue             As Long
     
    'Users - select a cell on a worksheet
        MsgBoxValue = MsgBox( _
                        Prompt:=strPrompt, _
                        Buttons:=lngButtons, _
                        Title:=strTitle)
                        
    'Handle user actions
        If MsgBoxValue <> vbYes Then
            MsgBoxValue = vbCancel
        End If
         
    'Pass value to function
        GetUserMessageResponse = MsgBoxValue

 End Function

Function..TestForData

Now that I have a Cell on a Worksheet, I need to test to see if there is any data on the Worksheet. In the Function below, I first check Cell(1,1) for any data, if that does not contain any data, then I check the rest of the worksheet.

Here I am using the Find Method of the Range Object to search for anything on the Worksheet. More on the Range.Find Method (Excel).

Public Function TestForData(ws As Worksheet) As Boolean

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'TestForData
    'Returns a boolean datatype
    'Checks to see that data exists in at least 1 Cell on a Worksheet
    '
    'Parameters        :
    'ws                :   Required, A Woksheet Object.
    '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    'Declare variables
        Dim rng As Range
    
    'Initialize values
        TestForData = False
        
    'Check the worsheet for data
        On Error Resume Next
        If Not IsEmpty(ws.Cells(1, 1)) Then
            Set rng = ws.Cells(1, 1)
        Else
            With ws
                Set rng = .Cells.Find(What:="*", _
                                      After:=.Cells(1, 1), _
                                      LookIn:=xlFormulas, _
                                      LookAt:=xlPart, _
                                      SearchOrder:=xlByRows, _
                                      SearchDirection:=xlPrevious, _
                                      MatchCase:=False)
            End With
        End If
    
    'Update function value if the worksheet contains data
        If Not rng Is Nothing Then TestForData = True
  
    'Tidy up
        Set rng = Nothing

End Function

And here is how I call the Function in the final Sub()

    'Check if the worksheet has any data
        blnFlag = TestForData(ws:=wsUserCell)

Function..Find First And Last Cells

So far, I have tested if the user clicked cancel or if the worksheet contains any data, at this point, I have passed those tests, so now I can get to the meat of it.

I have one Function to return either the first used Cell or the last used Cell – and that my friends is cool. I want my Functions() to be fast, efficient and flexible. I vary whether the Function() returns the last used Cell or first used Cell by passing a variable to the SearchDirection by using the values of the xlSearchDirection Enumeration: xlNext and xlPrevious.

When the SearchDirection is xlNext, the Function() returns the first used Cell. When the SearchDirection is xlPrevious, the Function() returns the last used Cell.

Public Function GetCell(ws As Worksheet, _
                        rng As Range, _
                        lngDirection As Long) As Range
                        
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'GetCell
    'Returns a Range Object based on a single Cell
    'The Cell is either the first Cell in a Range or the last Cell in a Range
    'The distinction is based on the parameter value passed to lngDirection by the user as either xlPrevious or xlNext
    '
    'Parameters        :
    'ws                :   Required, A Woksheet Object.
    'rng               :   Required, A Range Object.
    'lngDirection      :   Required, Either xlNext or xlPrevious.
    '                      Use xlPrevious when searching for the last used Cell.
    '                      Use xlNext when searching or the first used cell.
    '
    'Use               :   Find the last used Cell first
    '                  :   Pass the last used Cell as a Range Object to the function to determine the first used Cell
    '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    'Get range as a single cell
        With ws
            Select Case lngDirection
                Case xlNext
                    If Not IsEmpty(.Cells(1, 1)) Then
                        Set rng = .Cells(1, 1)
                    Else
                        Set rng = .Cells.Find(What:="*", _
                                              After:=rng, _
                                              LookIn:=xlFormulas, _
                                              LookAt:=xlPart, _
                                              SearchOrder:=xlByRows, _
                                              SearchDirection:=lngDirection, _
                                              MatchCase:=False)
                    End If
                Case xlPrevious
                    Set rng = .Cells.Find(What:="*", _
                                          After:=rng, _
                                          LookIn:=xlFormulas, _
                                          LookAt:=xlPart, _
                                          SearchOrder:=xlByRows, _
                                          SearchDirection:=lngDirection, _
                                          MatchCase:=False)
            End Select
        End With
        
    'Pass the range to the function
        Set GetCell = rng

    'Tidy up
        Set rng = Nothing

End Function

When I call the Function() to get the last used Cell, I pass Cell(1,1) to the Function() and appropriate enumeration value for SearchDirection:

            'Get last cell
                Set rngLastCell = GetCell(ws:=wsUserCell, _
                                          rng:=wsUserCell.Cells(1, 1), _
                                          lngDirection:=xlPrevious)

When I call the Function() to get the first used Cell, I pass the Range Object created in the first call to the Function() and appropriate enumeration value for SearchDirection:

            'Get first cell
                Set rngFirstCell = GetCell(ws:=wsUserCell, _
                                           rng:=rngLastCell, _
                                           lngDirection:=xlNext)

The Final Sub()…GetTrueUsedRange

And here’s the final Sub() to bring it all together:

Option Explicit
Sub GetTrueUsedRange()

    'Declare variables
        Dim wb As Workbook
        Dim wsUserCell As Worksheet
        Dim rngUserCell As Range
        Dim rngStart As Range
        Dim rngLastCell As Range
        Dim rngFirstCell As Range
        Dim rngTrueUsedRange As Range
        Dim blnDataExists As Boolean
        Dim lngMessageResponse As Long
        Dim lngFirstCellRow As Long
        Dim lngFirstCellColumn As Long
        Dim lngLastCellRow As Long
        Dim lngLastCellColumn As Long
    
    'Initialize
        Set wb = ThisWorkbook
    
    'Prompt user to select a cell on a worksheet
        Set rngUserCell = GetUserSelectedCell( _
                            strPrompt:="Please select a cell on a worksheet.", _
                            strTitle:="Get Cell Selection From User")
                                          
    'Get the worksheet that contains the cell the user selected
        If Not rngUserCell Is Nothing Then
            Set wsUserCell = rngUserCell.Parent
        Else
            lngMessageResponse = GetUserMessageResponse( _
                                    strPrompt:="The selected worksheet does not contain any data." & vbLf & _
                                               "Or you clicked ""Cancel.""" & vbLf & _
                                               "Would you like to try a different worksheet?", _
                                    strTitle:="Missing Data Warning", _
                                    lngButtons:=vbYesNo)
        End If
    
    'Check if the worksheet has any data
        blnDataExists = TestForData(ws:=wsUserCell)
        
    'If the worksheet does not have any data, ask the user to select a different worksheet or exit
        If blnDataExists = False Then
            lngMessageResponse = GetUserMessageResponse( _
                                    strPrompt:="The selected worksheet does not contain any data." & vbCrLf & _
                                               "Would you like to try a different worksheet?", _
                                    strTitle:="Missing Data Warning", _
                                    lngButtons:=vbYesNo)

            If lngMessageResponse = vbYes Then
                Call GetTrueUsedRange   'Recursive call
                Exit Sub
            Else
                MsgBox "You clicked ""No"" or ""Cancel"". Now exiting.", vbInformation, "No Data Warning"
                Exit Sub
            End If
        Else
        
            'Get last cell
                Set rngLastCell = GetCell(ws:=wsUserCell, _
                                          rng:=wsUserCell.Cells(1, 1), _
                                          lngDirection:=xlPrevious)
                With rngLastCell
                    lngLastCellRow = .Row
                    lngLastCellColumn = .Column
                End With
                
            'Get first cell
                Set rngFirstCell = GetCell(ws:=wsUserCell, _
                                           rng:=rngLastCell, _
                                           lngDirection:=xlNext)
                                           
                With rngFirstCell
                    lngFirstCellRow = .Row
                    lngFirstCellColumn = .Column
                End With
        
        End If
        
    'Create true used range
        Set wsUserCell = wb.ActiveSheet
        Debug.Print "Worksheet", wsUserCell.Name
        With wsUserCell
            Set rngTrueUsedRange = .Range(.Cells(lngFirstCellRow, lngFirstCellColumn), _
                                          .Cells(lngLastCellRow, lngLastCellColumn))
        End With
    
    'Results
        Debug.Print "True used range", rngTrueUsedRange.Address

    'Tidy up
        If Not rngUserCell Is Nothing Then Set rngUserCell = Nothing
        If Not rngStart Is Nothing Then Set rngStart = Nothing
        If Not rngLastCell Is Nothing Then Set rngLastCell = Nothing
        If Not rngFirstCell Is Nothing Then Set rngFirstCell = Nothing
        If Not rngTrueUsedRange Is Nothing Then Set rngTrueUsedRange = Nothing
        If Not wsUserCell Is Nothing Then Set wsUserCell = Nothing
        If Not wb Is Nothing Then Set wb = Nothing
End Sub

Tidy Up

I tested the Sub() on several different Worksheets with a variety of placement of data, no data and single cells of data. All tests returned correct expected results. Please let me know if your tests return incorrect results.

How do you find the True Used Range on your Worksheets?

, , , , ,

SpyVsSpyLg

In January, I wrote a post that demonstrated how to combine Excel Workbooks. That post assumed that each of the source workbooks contained at least one ListObject Object.

Today, I will revise that code a bit to add a ListObject Object (LO) if the lo does not exist. Then I will demonstrate the code to merge Workbooks using Range Objects. Lastly, I will compare both processes to see which is the fastest using the Windows High Resolution Timer.


    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


The ListObject Object (LO)

One of the very useful features the LO, is that it offers us the three distinct properties: HeaderRowRange, DataBodyRange, TotalsRowRange. Once we have a LO, we can leverage these properties to streamline the heavy lifting.

ListObjectRanges

Check If The ListObject Object Exists

I can check if the LO exists, if not, I can add one while I’m looping through workbooks:

Option Explicit

Sub AddListObjectIfDoesNotExist()

    'Does a  ListObject Object exist?
    
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim lo As ListObject
    
    Set wb = ThisWorkbook
    For Each ws In wb.Worksheets
        Set lo = ws.Range("A1").ListObject
        If lo Is Nothing Then
            Set lo = ws.ListObjects.Add( _
                                    SourceType:=xlSrcRange, _
                                    Source:=ws.Range("A1").CurrentRegion, _
                                    Destination:=ws.Range("A1"))
        Else
            'ListObject already exists - do nothing
        End If
    Next ws
    
    'Tidy up
        Set lo = Nothing
        Set wb = Nothing
End Sub

Now that I can add an LO dynamically, I can exploit its properties with assurance.

Here is the fully revised code to merge Excel Workbooks using ListObject Objects:

Option Explicit
 
Sub MergeWorbooksUsingListObjects()
     
    'Log:
    'Date               Author                      Action                  Comment
    '-------------------------------------------------------------------------------------------------------------------
    '1/26/2014           ws                         Created                 Merge workbooks using ListObjects from source files
    '3/23/2014           ws                         Modified                If ListObject does not exist, add ListObject
    '-------------------------------------------------------------------------------------------------------------------
     
    'Delare variables
        Dim wb                  As Workbook
        Dim wbData              As Workbook
        Dim ws                  As Worksheet
        Dim wsData              As Worksheet
        Dim rngData             As Range
        Dim rngDestination      As Range
        Dim lo                  As ListObject
        Dim fso                 As Object
        Dim fsoFolder           As Object
        Dim fsoFile             As Object
        Dim strSelectedFolder   As String
        Dim strCurrentPath      As String
        Const strSpecifiedPath  As String = "C:\"
        Dim lngRows             As Long
        Dim blnFlag             As Boolean
         
    'Excel environment - speed things up
        With Application
            .ScreenUpdating = False
            .DisplayAlerts = False
            .EnableEvents = False
            .Calculation = xlCalculationManual
        End With
         
    'Initialize variables
        Set wb = ThisWorkbook
        Set ws = wb.Worksheets("Data")
        blnFlag = True
         
    'Clear data from control workbook from previous consolidations
        ws.UsedRange.ClearContents
     
    'Get the current path, so reset the path at the end of the procedure
        strCurrentPath = CurDir()
         
    'Set the target directory to get the user closer to the working folder
    'This will minimize the time the user must spend drilling into the file system
    'once they are presented with the FileDialog
        ChDir (strSpecifiedPath)
     
    'Create a FileSystemObject
        Set fso = GetFSO
 
    'Prompt the user to select a folder
    'Return the path of the selected folder
        strSelectedFolder = GetSelectedFolder
         
    'Get the FSO Folder of the selected folder
        Set fsoFolder = fso.GetFolder(strSelectedFolder)
         
    'Loop each file in folder
    'Copy data from each file to control workbook
        For Each fsoFile In fsoFolder.Files
            Set wbData = Workbooks.Open(fsoFile)
            Set wsData = wbData.Worksheets("Sheet1")
             
            'Get next blank row from destination worksheet
            'If first time, need row 1, else, next blank row
                lngRows = GetRows(ws:=ws)
                If blnFlag = False Then lngRows = lngRows + 1
                 
            'The Destination Range
                Set rngDestination = ws.Cells(lngRows, 1)
             
            With wsData
                'If a ListObject does not exist, add a ListObject
                    Set lo = .Range("A1").ListObject
                    If lo Is Nothing Then
                        Set lo = .ListObjects.Add( _
                                              SourceType:=xlSrcRange, _
                                              Source:=.Range("A1").CurrentRegion, _
                                              Destination:=ws.Range("A1"))
                    Else
                        'Do nothing, ListObject already exists
                    End If
                
                'If first workbook, include the header row
                    For Each lo In .ListObjects
                        If blnFlag = True Then
                            Set rngData = Union(lo.HeaderRowRange, lo.DataBodyRange)
                            blnFlag = False
                        Else
                            Set rngData = lo.DataBodyRange
                        End If
                    Next lo
            End With
  
            'Copy the Data Range to the Destination Range
                rngData.Copy
                rngDestination.PasteSpecial xlPasteValuesAndNumberFormats
                 
            'Close the source file without saving
                wbData.Close
         
        Next fsoFile
         
    'Tidy up
        'Restore to original path
            ChDir (strCurrentPath)
             
        'Restore Excel environment
            With Application
                .ScreenUpdating = True
                .DisplayAlerts = True
                .EnableEvents = True
                .Calculation = xlCalculationAutomatic
            End With
             
        'Destroy objects
            Set fsoFolder = Nothing
            Set fso = Nothing
            Set lo = Nothing
            Set rngData = Nothing
            Set rngDestination = Nothing
            Set ws = Nothing
            Set wb = Nothing
         
End Sub

And the functions:


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

'-------------------------------------------------------------------------
Public Function GetFSO()
 
    Dim fso             As Object
     
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set GetFSO = fso
     
    Set fso = Nothing
 
End Function

'-------------------------------------------------------------------------
Public Function GetSelectedFolder() As String
     
    Dim diaFolder       As FileDialog
    Dim strFolder       As String
 
    Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
    With diaFolder
        .AllowMultiSelect = False
        .Show
        strFolder = .SelectedItems(1)
    End With
 
    GetSelectedFolder = strFolder
End Function

Works great!

The Range Object

The Range Object does not have the properties: HeaderRowRange, DataBodyRange, TotalsRowRange. I am ok with the entire Range from the first Workbook when Merging multiple Workbooks. But on subsequent Workbooks, I want to exclude the header row.

Assume I have a Range named rng with address $A$1:$G$10, from this, I would like to exclude the header row on Row 1. The first step is to count the number of rows and columns in the range

Dim r As Long
dim c As Long
r = rng.Rows.Count
c = rng.Columns.Count

Next, from the rng, move down 1 Row. This means the rng address is now $A$2:$G$11

rng.Offset(1)

The $A$2 part of the address is good, but the $G$11 part means I now have a blank row. So now I need to Resize the rng to exclude the blank row:

rng.Offset(1).Resize(r-1,c)

And test the final Range Address to make sure all is as expected:

Debug.Print rng.Address

$A$2:$G$10

Perfect! Exactly what I was looking for. I’m now ready to modify the code again to use Range Objects instead of ListObject Objects.

Merge Workbooks Using Range Objects

Here’s the working code to merge workbooks using Range Objects instead of ListObject Objects:

Option Explicit
 
Sub MergeWorbooksUsingRangeObjects()
     
    'Log:
    'Date               Author                      Action                  Comment
    '-------------------------------------------------------------------------------------------------------------------------------------------
    '1/26/2014           ws                         Created                 Merge workbooks using ListObjects from source files
    '3/23/2014           ws                         Modified                If ListObject does not exist, add ListObject
    '3/23/2014           ws                         Modified                Use Range Object, modify range to exclude header row if not File = 1
    '-------------------------------------------------------------------------------------------------------------------------------------------
     
    'Delare variables
        Dim wb                  As Workbook
        Dim wbData              As Workbook
        Dim ws                  As Worksheet
        Dim wsData              As Worksheet
        Dim rngData             As Range
        Dim rngDestination      As Range
        Dim fso                 As Object
        Dim fsoFolder           As Object
        Dim fsoFile             As Object
        Dim strSelectedFolder   As String
        Dim strCurrentPath      As String
        Const strSpecifiedPath  As String = "C:\"
        Dim lngRows             As Long
        Dim r                   As Long
        Dim c                   As Long
        Dim blnFlag             As Boolean
         
    'Excel environment - speed things up
        With Application
            .ScreenUpdating = False
            .DisplayAlerts = False
            .EnableEvents = False
            .Calculation = xlCalculationManual
        End With
         
    'Initialize variables
        Set wb = ThisWorkbook
        Set ws = wb.Worksheets("Data")
        blnFlag = True
         
    'Clear data from control workbook from previous consolidations
        ws.UsedRange.ClearContents
     
    'Get the current path, so reset the path at the end of the procedure
        strCurrentPath = CurDir()
         
    'Set the target directory to get the user closer to the working folder
    'This will minimize the time the user must spend drilling into the file system
    'once they are presented with the FileDialog
        ChDir (strSpecifiedPath)
     
    'Create a FileSystemObject
        Set fso = GetFSO
 
    'Prompt the user to select a folder
    'Return the path of the selected folder
        strSelectedFolder = GetSelectedFolder
         
    'Get the FSO Folder of the selected folder
        Set fsoFolder = fso.GetFolder(strSelectedFolder)
         
    'Loop each file in folder
    'Copy data from each file to control workbook
        For Each fsoFile In fsoFolder.Files
            Set wbData = Workbooks.Open(fsoFile)
            Set wsData = wbData.Worksheets("Sheet1")
             
            'Get next blank row from destination worksheet
            'If first time, need row 1, else, next blank row
                lngRows = GetRows(ws:=ws)
                If blnFlag = False Then lngRows = lngRows + 1
                 
            'The Destination Range
                Set rngDestination = ws.Cells(lngRows, 1)
             
            With wsData
                'Create the data range
                    Set rngData = .Range("A1").CurrentRegion
                    r = rngData.Rows.Count
                    c = rngData.Columns.Count
                
                'If first workbook, include the header row, otherwise resize the range to exclude the header row
                    If blnFlag = True Then
                        blnFlag = False
                    Else
                        Set rngData = rngData.Offset(1).Resize(r - 1, c)
                    End If
            End With
  
            'Copy the Data Range to the Destination Range
                rngData.Copy
                rngDestination.PasteSpecial xlPasteValuesAndNumberFormats
                 
            'Close the source file without saving
                wbData.Close
         
        Next fsoFile
         
    'Tidy up
        'Restore to original path
            ChDir (strCurrentPath)
             
        'Restore Excel environment
            With Application
                .ScreenUpdating = True
                .DisplayAlerts = True
                .EnableEvents = True
                .Calculation = xlCalculationAutomatic
            End With
             
        'Destroy objects
            Set fsoFolder = Nothing
            Set fso = Nothing
            Set rngData = Nothing
            Set rngDestination = Nothing
            Set ws = Nothing
            Set wb = Nothing
         
End Sub

That worked well, next I’ll add a little bit of code to time each of the Subs() to see if there is any appreciable difference.

Windows High-Resolution Timer (WHRT)

To use WHRT, I’ll just need to add 3 lines of code:

Declare a reference to the kernel32 library

Public Declare Function GetTickCount Lib "kernel32.dll" () As Long

Get the tick count and assign it to a variable

t = GetTickCount

Get the tick count at the end, subtract the first to calculate elapsed time

debug.print GetTickCount - t & " Milliseconds"

I’ll put the Public Function “GetTickCount” in a Module with my other Public Functions.
I normally put the first call to the Public Function near the top of a Sub(), but in this case I’m using a FileDialog to interact with the user so I want to place the call to the Function after the FileDialog:

    'Prompt the user to select a folder
    'Return the path of the selected folder
        strSelectedFolder = GetSelectedFolder
        
    'Get the tick count
        t = GetTickCount

The last call to the GetTickCount Function goes at the very end of the code:

            Set ws = Nothing
            Set wb = Nothing
            
        'Get elapsed time
             Debug.Print GetTickCount - t & " Milliseconds"

The Results

The Sub() adding the ListObject Object dynamically:

1420 Milliseconds
1233 Milliseconds
1419 Milliseconds
1419 Milliseconds
1248 Milliseconds
1451 Milliseconds
1435 Milliseconds
1264 Milliseconds
1653 Milliseconds
1264 Milliseconds
——————–
1380.6 Milliseconds Avg

The Sub() Resizing the Range Object:

1217 Milliseconds
1217 Milliseconds
1451 Milliseconds
1264 Milliseconds
1232 Milliseconds
1232 Milliseconds
1248 Milliseconds
1263 Milliseconds
1264 Milliseconds
1248 Milliseconds
————————
1263.6 Milliseconds Avg

Tidy Up

    Final Thoughts

    The Sub() using the Range Object is a bit faster, but not much. Bear in mind, I ran the process on 3 files -each file with 50 rows and 7 columns. The results may be more pronounced on more files with more data in each file.

    Downloads

    Download the file containing both Subs() and all Functions here.

    Additional Resources

    ListObject Objects

    ListObject Object Model
    ListObjects Object Model
    Working with Tables in Excel 2013, 2010 and 2007 (VBA)
    Working with Microsoft Excel tables in VBA

    Range Object

    The Range Object – Object Model

, , ,


Duke
 
I’m a sucker for a good western. Here’s John Wayne as Rooster Cogburn in True Grit the only film for which Wayne won the Oscar for Best Actor. Wayne and a partner owned a ranch not far from here and tales spin around the old town of Wayne and actor buddy, Lee Marvin, closing down a local cantina many a night back in the day.

But I digress, as this post is not about life out here in the open range of the wild west. Rather, it is about the Range Object of the Excel Object Model. The Range Object has 78 Methods and 96 Properties. I’ll take a look at some of these over a series of posts. I’ll begin with these methods:

  1. AdvancedFilter
  2. AutoFilter
  3. Find
  4. SpecialCells
  5. PasteSpecial

AdvancedFilter

Here’s a code snippet of the final code at the bottom that demonstrates some of the syntax for the AdvancedFilter Method:

Range.AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=wsCriteria.Cells(1, 1), _
                Unique:=True

The most important parameters here are the Action and Unique parameters. This allows us to quickly get a unique list of data from the dataset that we can use as the criteria for the AutoFilter later

AutoFilter

Here’s a code snippet of the final code at the bottom that demonstrates some of the syntax for the AutoFilter Method:

    Range.AutoFilter _
             Field:=lngField, _
             Criteria1:=varCriteria

There are additional parameters available for the AutoFilter Method and I encourage you to investigate those. See the link at the bottom of this post. For now, I want to point out that I am passing variables to the named parameters. In the next section you’ll see how I use the Find Method to determine the column number of the header that I am interested in as “lngField”.

As I loop though the list of criteria created in the AdvancedFilter process I pass the value as “varCriteria” to the AutoFilter process.

Find

Here’s a code snippet of the final code at the bottom that demonstrates some of the syntax for the Find Method:

lngField = rngHeader.Find(What:=strFieldName, _
                          LookIn:=xlValues, _
                          LookAt:=xlWhole, _
                          MatchCase:=False).Column

The Find Method allows us to get a value at run-time using an InputBox for example, find the item, and pass the column number where the item is located to our process. This makes the process more robust and dynamic.

SpecialCells

Here’s a code snippet of the final code at the bottom that demonstrates some of the syntax for the SpecialCells Method:

Range.SpecialCells(xlCellTypeVisible).Copy

When most folks begin using VBA, they tend to loop through cells. However, SpecialCells used in conjunction with AutoFilter can offer much significant performance improvements as looping through cells tends to be slower. There are many types (enumeration) of SpecialCells. Link at bottom for full list. In the code sample below, I am using xlCellTypeVisible thereby ignoring all rows hidden by the AutoFilter.

PasteSpecial

Here’s a code snippet of the final code at the bottom that demonstrates some of the syntax for the PasteSpecial Method:

wbBifurcate.Worksheets("Sheet1").Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats

There are 11 other paste types in the enumeration. I encourage you to explore them all. See the link at the bottom of this post.

Case Study: Bifurcate Excel File

ExcelSplitA common question posted on the LinkedIn Groups is, “How to split (bifurcate) an Excel file based on some criteria within the file?”

We need some test data so I downloaded a random data generator add-in over at Daily Dose of Excel by Dick Kusleika and whipped up some data:
 
BData
 Looks good so far. Now I’d like to bifurcate the master data into separate files based on the company name.

Get a unique list of company names

I’ll leverage the “unique” parameter of the AdvancedFilter Method of the Range Object

Range.AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=wsCriteria.Cells(1, 1), _
                Unique:=True

CData

The Complete Code

Option Explicit

Sub BifurcateFile()

    'Author:Winston Snyder
    'Date: 12/7/2013
    'Purpose: Bifurcate master file into component files
    
    'Declare variables
        Dim wb As Workbook
        Dim wbBifurcate As Workbook
        Dim ws As Worksheet
        Dim wsCriteria As Worksheet
        Dim rngList As Range
        Dim rngData As Range
        Dim rngCriteria As Range
        Dim rngHeader As Range
        Dim r As Long
        Dim c As Long
        Dim i As Long
        Dim lngField As Long
        Dim rCriteria As Long
        Dim strFieldName As String
        Dim strPath As String
        Dim varCriteria As Variant
        
    'Excel environment - speed things up
        With Application
            .ScreenUpdating = False
            .DisplayAlerts = False
            .EnableEvents = False
            .Calculation = xlCalculationManual
        End With
        
    'Intialize variables
        Set wb = ThisWorkbook
        Set ws = wb.Worksheets("Data")
        strFieldName = InputBox("Please enter the term to search for?") '<-Update as needed
        strPath = DocsPath & "Load Files\" '<-File output, update as needed
        r = ws.Cells(Rows.Count, 1).End(xlUp).Row
        c = ws.Cells(1, Columns.Count).End(xlToLeft).Column
        
    'Add a worksheet to hold filtered data
    'This list will become the criteria list for bifurcating the master file
        Set wsCriteria = wb.Worksheets.Add(After:=Worksheets(Worksheets.Count))
        
    'Find column number to be filtered
        Set rngHeader = ws.Range(ws.Cells(1, 1), ws.Cells(1, c))
        lngField = rngHeader.Find(What:=strFieldName, _
                                  LookIn:=xlValues, _
                                  LookAt:=xlWhole, _
                                  MatchCase:=False).Column
        
    'Define the range to be filtered
        With ws
            If .FilterMode = True Then
                .ShowAllData
            End If
                        
            Set rngList = .Range(.Cells(1, lngField), .Cells(r, lngField))
            Set rngData = .UsedRange
        End With
        
    'Filter the range
        With rngList
            .AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=wsCriteria.Cells(1, 1), _
                Unique:=True
        End With
        
    'Define the criteria range
    'Begin with row 2 to ignore the header row
        With wsCriteria
            rCriteria = .Cells(Rows.Count, 1).End(xlUp).Row
            Set rngCriteria = .Range(.Cells(2, 1), .Cells(rCriteria, 1))
        End With
        
    'Loop through criteria range
    'Use each value as criteria to apply to autofilter for data range
    'Create file
        For i = rngCriteria.Rows.Count To 1 Step -1
            varCriteria = rngCriteria.Cells(i, 1).Value
            
            'Add a workbook to hold filtered results
                Set wbBifurcate = Workbooks.Add
                
            'Filter the original data
                With ws
                    
                    'If data is filtered, remove filter
                        If .FilterMode = True Then
                            .ShowAllData
                        End If
                    
                    'Filter the data
                        .AutoFilterMode = False
                        If Not .AutoFilterMode Then
                            rngData.AutoFilter _
                                Field:=lngField, _
                                Criteria1:=varCriteria
                        End If
                            
                    'Copy the visible range of the data range - include the header row
                        rngData.SpecialCells(xlCellTypeVisible).Copy
                        wbBifurcate.Worksheets("Sheet1").Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats
                        
                    'Remove the autofilter
                        If .AutoFilterMode = True Then
                            .AutoFilterMode = False
                        End If
                        
                End With
                
            'Save the bifurcated data workbook
                wbBifurcate.SaveAs strPath & varCriteria & ".xlsx", FileFormat:=51
                
            'Close the workbook
                wbBifurcate.Close
            
        Next i
        
    'Tidy up
        'Delete temporary worksheet
            wsCriteria.Delete
            
        'Delete objects
            Set rngList = Nothing
            Set rngData = Nothing
            Set rngCriteria = Nothing
            Set rngHeader = Nothing
            Set wsCriteria = Nothing
            Set ws = Nothing
            Set wbBifurcate = Nothing
            Set wb = Nothing
            
        'Excel environment - restore
            With Application
                .ScreenUpdating = True
                .DisplayAlerts = True
                .EnableEvents = True
                .Calculation = xlCalculationAutomatic
            End With
End Sub
Public Function DocsPath() As String
    
    'Purpose: Get the Environ value for User Docuents
    'Returns: C:\Users\%User Name%\Documents\
    
    DocsPath = Environ$("USERPROFILE") + "\Documents\"
End Function

I’m using the DocsPath function to get the Documents folder based on which user is logged in. This makes the code a bit more robust and transportable. I should really check for the existence of a subfolder or offer the user the option to create the subfolder if it does not exist – but I feel that complicates the code which may already be complicated enough.

Tidy up

    Final Thoughts

    The sample does take a little bit of time to run as there are 100K records and 100 unique company names – therefore 100 separate files. I’ve seen varying attempts to use passwords and other techniques to allow a user to only view certain data. However, the best way to make sure a user cannot access data that you do not want them to see is to make sure it is not in the workbook in the first place.

    The process may be faster if instead of looping through a range, we first transfer the range to an array and then loop the array to pass the elements of the array as criteria for the autofilter.

    Another option might be to get the size of each range after the autofilter, set the size of the receiving range and then transfer the value of one range to another. This would bypass the Windows Clipboard which is causing the process to run a little slower using the Copy-PasteSpecial. Something like:

    Set rngSource = Range.SpecialCells(xlCellTypeVisible)
    With rngSource
         rowsSource = .Rows.Count
         columnsSource = .Columns.Count
    End With
    
    Set rngDestination = wbBifurcate.Worksheets("Sheet1").Range("A1")
    Set rngDestination = rngDestination.Resize(rowsSource,columnsSource)
    
    rngDestination.Value = rngSource.Value
    

    The process I use above in the main code, may be used in conjunction with varying methods of automated distribution such as through Outlook or TransferSharePointList. Additionally, instead of pasting values into a new workbook, I could use a template workbook that has Pivot Tables, Charts, Formulas – everything that is needed – just need to append the new data or delete any old data and paste in the new data. I’ll post samples of those processes in future posts.

    Downloads

    Download the workbook from SkyDrive.

    Additional Resources

, ,