Utilities Archives - Page 3 of 4

Filter as you type with FilterMatic!

Posted on October 27, 2013 by Doug Glancy

Whenever possible I employ lookups, crosswalks and whining to avoid correcting data by hand. Sometimes my best efforts fail, and I end up fixing lists one funky cell at a time. The horror! Happily I’ve created FilterMatic to ease the pain.

Say for instance, you’re giving a birthday party for a hundred or so of your oldest friends, all born on October 26. You’ve got this handy reference list of names, years of birth and notable accomplishment:

source:http://www.historyorb.com/today/birthdays.php

Meanwhile you’ve got another, very similar, list that calculates their age – with a lookup to the “year” column on the first list – so you can embarrass them by putting it on their place setting. The problem is some names are misspelled and you’re getting #N/A’s.

So you filter to just the #N/A’s and start to fix them. Wouldn’t it be nice if, as you fixed the errors, they were automatically filtered away? It’s true that in modern Excel tables you can do this with right-click>Filter>Re-Apply. But now with FilterMatic your corrections are instantly whisked from sight!

In the example below, I’m fixing the names, at first without FilterMatic running. After the third fix, I start it up. The first thing that happens is the filter is re-applied. After that the filter is re-applied with every change to the table and each fixed row is filtered away.

FilterMatic™ works on worksheet and table filters, re-applying them on the active sheet whenever you change a cell within a filtered area. And with FilterMatic™ there’s no confusing buttons or messy dropdowns. Just turn it on to start filtering! Close it when you’re done! But wait, there’s more! Download now and receive a free puppy!

Here’s the code:

Private WithEvents app As Excel.Application
Private WithEvents wsActive As Excel.Worksheet
'My ShowModal Property must be set to False

Private Sub UserForm_Activate()
Set app = Application
If Not ActiveSheet Is Nothing Then
Set wsActive = ActiveSheet
FilterMatic
End If
End Sub

Private Sub app_SheetActivate(ByVal Sh As Object)
Set Sh = wsActive
End Sub

Private Sub wsActive_Change(ByVal Target As Range)
FilterMatic
End Sub

Private Sub lblFilterMatic_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'apply changes by double-clicking the form
FilterMatic
End Sub

Sub FilterMatic()
Dim lo As Excel.ListObject

Set lo = Selection.ListObject
'if the selection overlaps a table
If Not lo Is Nothing Then
With lo
'Table is in filter mode
If .ShowAutoFilter Then
.AutoFilter.ApplyFilter
End If
End With
Else
'It will only re-apply a worksheet-level filter if
'there's no tables on the sheet.
With wsActive
'if sheet is filtered
If .FilterMode = True Then
'if the selection overlaps the worksheet's filtered area
If Not Intersect(Selection, .AutoFilter.Range) Is Nothing Then
.AutoFilter.ApplyFilter
End If
End If
End With
End If
End Sub

When the form is opened an application object is created. This object monitors all “SheetActivate” events in Excel and sets the activated worksheet to wsActive. There are three events that trigger the filtering code: opening the form, changing something in wsActive or clicking the label in the center of the form.

The FilterMatic sub checks for both ListObject and worksheet-level filters. If the selection at the time of the change intersects one, then that filter is updated. Note that if a listobject is found, it won’t go on to re-apply a worksheet filter. I tried that and couldn’t imagine a reasonable worksheet design that would have both filter types, and anyways the results were weird. Also note that if you change two listobjects at once, the filter would only be applied to one of them: whichever is the Selection.ListObject.

Here’s a workbook with the code and the lists.

And be sure to join the email list so you won’t miss my next exciting product: PivotMasher!

Get Unique Per-Row Values With RemoveDuplicates

Posted on October 10, 2013 by Doug Glancy

This post consists of two topics, both involving VBA’s RemoveDuplicates method. First I discuss an error and a shortcoming in the RemoveDuplicates documentation that have confounded myself and others. After those are cleared up I’ll show how to use RemoveDuplicates to return a two-dimensional array of unique items from a range containing one or more columns.

RemoveDuplicates was added to VBA (along with it’s front-end counterpart Data>Remove Duplicates) in Excel 2007. It’s very handy, allowing you to select one or more columns in a range and and winnow it down to the rows where the combined values of those columns are unique. It does this “in-place,” leaving other areas of the sheet intact.

RemoveDuplicates’ Columns Argument isn’t Really Optional

The Excel 2013 MSDN documentation describes the variant Columns argument as an optional “Array of indexes of the columns that contain the duplicate information. If nothing is passed then it assumes all columns contain duplicate information.” (my emphasis)

Later it gives an example of leaving out the Columns argument to remove duplicates from the entire range:

“The following code sample removes duplicates with all columns from a range.”

ActiveSheet.Range("A1:C100").RemoveDuplicates

However, testing reveals that the above code does nothing. This is confirmed by the perplexed comments of various forum visitors. In truth, you have to specify the columns variant array in all cases. The help example should look like this:

ActiveSheet.Range("A1:C100").RemoveDuplicates Columns:=Array(1,2,3)

If you want to base the removal on just some of the columns in a range, for example columns A and C, you do it like this:

ActiveSheet.Range("A1:C100").RemoveDuplicates Columns:=Array(1,3)

Using a Dynamic Columns Array

If you use RemoveDuplicates in code, there’s a good chance you’ll want to determine the array of column numbers at runtime and not hard-code them as above. As a simple test, I tried something like:

Dim ColumnsToCheck as Variant
ColumnsToCheck = Array(1,3)
ActiveSheet.Range("A1:C100").RemoveDuplicates Columns:=ColumnsToCheck

However this results in a Runtime Error ‘5’ – Invalid Procedure Call or Argument.

After looking around the web a while I found that the answer is to wrap ColumnsToCheck in parentheses, so the code becomes:

Dim ColumnsToCheck as Variant
ColumnsToCheck = Array(1,3)
ActiveSheet.Range("A1:C100").RemoveDuplicates Columns:=(ColumnsToCheck)

I know, from one of my all-time favorite DDOE posts that parentheses force evaluation of what’s inside them. Others on the web said that these parens “coerce” the evaluation of the array. I don’t really see how that applies here, so if you can explain why this works, please leave a comment.

One other note about the Columns variant array – it must be zero-based.

Unique Unique Per-Row Values Array Function

Once I’d sorted out the above points, I was able to use RemoveDuplicates as the basis of a function that returns a two-dimensional variant array containing the unique rows in a range. The range can consist of multiple columns that aren’t necessarily adjacent, as in this table of hometowns and sports of 2008 US Olympic athletes:

In the example above I want to return a variant array of all the unique combinations of the State and Sport fields. The specific use is for a worksheet splitter, where I prompt the user for one or two columns and the cycle through the array of unique combinations, creating a separate workbook for each combination.

The code is simple enough. It takes a range as it’s argument, for example the State and Sport fields above. It copies the range it to a worksheet in a newly added workbook. We then use RemoveDuplicates on the entire UsedRange of that new sheet. Because the columns are now contiguous the code can easily assign the modified range back to a variant array. The temporary workbook is then closed without saving.

Function GetUniqueRowValues(rng As Excel.Range) As Variant
Dim wbTemp As Excel.Workbook
Dim wsTemp As Excel.Worksheet
Dim ColNums As Variant
Dim i As Long

'if only one cell selected then can't pass to two-dimensional array
If rng.Cells.Count = 1 Then
'if the single cell is blank
If rng.Value = vbEmpty Then
Exit Function
Else
GetUniqueRowValues = rng.Value
Exit Function
End If
End If

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'create a temp workbook
'and copy range to it
Set wbTemp = Workbooks.Add
Set wsTemp = wbTemp.Worksheets(1)
With wsTemp
rng.Copy
'rng can consist of non-adjactent columns
'pasting to a new workbook results in a
'new range with only those columns
.Range("A1").PasteSpecial xlPasteValues
ReDim ColNums(0 To wsTemp.UsedRange.Columns.Count - 1)
'Create the array of column numbers for the
'RemoveDuplicates' Columns parameter
For i = LBound(ColNums) To UBound(ColNums)
ColNums(i) = i + 1
Next i
.UsedRange.RemoveDuplicates Columns:=(ColNums), Header:=xlGuess
'assign the values of the remaining,
'non-duplicated rows to the function result
GetUniqueRowValues = .UsedRange
End With
wbTemp.Close False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Function

Note that is the original range was just one cell, the returned variant will not be an array. But you’d test for that before running this in the first place, wouldn’t you?

This code is fast for big ranges, handling over one million rows in less than five seconds on my laptop. On the other hand, it has to open and close a workbook, which takes part of a second and causes screen flicker. It’s a lot more flexible at least than my attempts to modify the Collection technique to handle large ranges with non-adjacent columns.

More Listbox Filtering With the Like Operator

Posted on September 12, 2013 by Doug Glancy

Since posting about filtering a listbox, I’ve been thinking a lot about VBA’s Like operator. I realized I could type in filters such as ‘[4-7]#‘ which matches two-digit numbers between 40 and 79. I raced to my computer to try it out, typed the opening bracket and was halted in my tracks:

It makes sense that a “[” without a “]” is untenable in a Like pattern. It needs the closing bracket to mark the end of the character set. On the other hand, a single “]” is legal and just stands for itself. You can match a left bracket by putting brackets around it, so the following expression in the Immediate Window yields True:

? "[" Like "[[]"

I set to creating a function that would detect the invalid left bracket. I tried testing whether there were more left than right brackets, but since you can have two left ones in a row, and as many right ones as you want, that wouldn’t fly. To avoid a complicated set of tests, I turned to the VBA standby of attempting something inside of On Error statements, something whose failure yields specific and helpful information, like “hey that’s an invalid pattern.”

Here was the first attempt, which seemed to do the trick:

Function ValidLikePattern(LikePattern As String) As Boolean
Dim temp As Boolean
On Error Resume Next
temp = ("A" Like LikePattern)
If Err.Number = 0 Then
ValidLikePattern = True
End If
On Error GoTo 0
End Function

You pass it a pattern and it tests it against the simplest possible string – “A”. My assumption was the test would either pass, if there was no left bracket, or fail if there was. I was wrong on two counts.

The first is that Like actually has three possible outcomes: True, False or Null. It returns Null if either the string being compared or the pattern is an empty string.

Much more important to my function, Like is lazy. It only tests as far as needed. So, while this returns an “Invalid pattern string” message:

? "A" Like "["

This doesn’t:

? "A" Like "A["

It just returns False. I guess Like compares the first characters, sees they match and checks whether the next one is an asterisk, the only character that could match at this point. Since it’s not, Like says “whatever” and quits, ignoring the left bracket’s tenuous status.

I could fix the function – kind of – by using a really long string in place of “A” and force Like to look harder. Instead I surrounded LikePattern in asterisks:

temp = ("A" Like "*" & LikePattern & "*")

This says there could be an infinite number of characters at the beginning of the pattern, so Like needs to be thorough and compare all the way through. I suppose this slows the code. I also guess I don’t need the “*” at the end. At any rate, I can now type a left bracket into the filter textbox without an error:

I updated the sample workbook from the ListBox Filter With WildCards post. It now calls the ValidLikePattern function at the beginning of the main loop. If the pattern isn’t valid, the loop is exited and the filtering stays the same until the next change in the filter textbox. Here’s the updated download.

Help Me Test Table Viewer

As I mentioned at the end of that post, I’m incorporating this logic and a bunch of features into a Table Viewer addin. I think it’s even more “freakin’ awesome” than MenuRighter. I’ve been using it every day. I just added the ability to specify exact matches, “contains”, “begins with”, etc. If you’d like to help me test it, please leave a comment or use the contact form to let me know. Or wait for my next post.

VBA FormatConditions – Per-Row ColorScales, DataBars and IconSets

Posted on February 17, 2013 by Doug Glancy

At the end of Conditional Formatting Per-Row Color Scales I said I’d be back with code to selectively copy IconSets and DataBars on a per-row basis as well. It took some doing but it’s now presentable. I learned a lot about programming these types of FormatConditions and I’m going to use this utility to generalize what I learned.

First, here’s a sample of the code in action. Some silly guy has added Icons, Data Bars and Color Scales to the values in Row 1. Now he’s copying only the ColorScales from that first row to the rows below:

I (okay, it’s me) adjust the setting and push the button. The button routine passes the values in the worksheet to the main routine. It’s an expanded version of the code in the previous post, with an addition to delete selected formats. The main procedure is available in the download workbook linked at the end of this post. (The delete code is interesting, and shown later in this post.)

ColorScale, IconSet and DataBar Subroutines

Below are the three subroutines, called from the main procedure, to copy each type of FormatCondition: ColorScales, IconSets and DataBars.

The structure of each of these objects is different. With the exception of the Formula property, ColorScale has no relevant properties in the base object. The properties that need to be copied are all within its ColorScaleCriterion object. IconSets have relevant properties both within the IconSet object and within its IconCriterion object. Finally, DataBars contain no criterion object. All of its relevant properties are set within the base DataBar object.

ColorScale

Here’s the ColorScale subroutine. You can see that the only property in the ColorScale object is the Formula property, which is an interesting one. As far as I can tell this property is only applicable through code. I’ll discuss it more below. It’s only sometimes applicable, and if it’s not it will generate an error when you refer to it. So I surround it with and On Error statement to avoid that.

Sub SetRangeColorScale(rngTargetSection As Excel.Range, csSource As Excel.ColorScale)
Dim csTarget As ColorScale
Dim csCriterion As ColorScaleCriterion

Set csTarget = rngTargetSection.FormatConditions.AddColorScale(csSource.Type)
On Error Resume Next
csTarget.Formula = csSource.Formula
On Error GoTo 0
For Each csCriterion In csSource.ColorScaleCriteria
With csTarget.ColorScaleCriteria(csCriterion.Index)
On Error Resume Next
.Type = csCriterion.Type
On Error GoTo 0
On Error Resume Next
.Value = isCriterion.Value
On Error GoTo 0
.FormatColor.Color = csCriterion.FormatColor.Color
.FormatColor.TintAndShade = csCriterion.FormatColor.TintAndShade
End With
Next csCriterion
End Sub

Aside from Formula, the properties that need to be copied are part of ColorScale’s ColorScaleCriterion object. They are Type, and the Color and TintAndShade shade properties of ColorScaleCriterion.FormatColor.

The Type property specifies whether a criterion is based on a number, percent, percentile or formula. Value sets the value to be used for the Type, for example, the 90th percentile or the appropriate formula. These properties all have their counterpart in the conditional formatting dialog, shown here with a formula for the Min and Max values:

I surrounded the Type and Value assignments in an On Error statement because only some of the criteria have them and you’ll get an error on the ones that don’t. Sheesh, this stuff is confusing!

IconSet

Aside from Formula, the IconSet object has three properties that need to be copied: IconSet, ReverseOrder and ShowIconOnly. IconSet determines the color and type of icons and the others should be obvious:

Sub SetRangeIconset(rngTargetSection As Excel.Range, isSource As Excel.IconSetCondition)
Dim isTarget As IconSetCondition
Dim isCriterion As IconCriterion

Set isTarget = rngTargetSection.FormatConditions.AddIconSetCondition
With isTarget
On Error Resume Next
.Formula = isSource.Formula
On Error GoTo 0
.IconSet = isSource.IconSet
.ReverseOrder = isSource.ReverseOrder
.ShowIconOnly = isSource.ShowIconOnly
For Each isCriterion In isSource.IconCriteria
With .IconCriteria(isCriterion.Index)
.Icon = isCriterion.Icon
On Error Resume Next
.Type = isCriterion.Type
On Error GoTo 0
On Error Resume Next
.Value = isCriterion.Value
On Error GoTo 0
.Operator = isCriterion.Operator
End With
Next isCriterion
End With
End Sub

At the IconCriterion level, there are four properties: Icon, Type, Value and Operator. Icon allows you to change individual icons, just like you can in the user interface. For example, here the gray arrow icon set has been modified to use a green ball in place of the gray up arrow:

Operator sets the relationship of the Icon to the Value. For example, the “>” Operator says to use an up arrow if the cell’s value is greater than the Value property.

DataBar

The DataBar object has no criterion property. All the relevant properties are at the DataBar level. So instead of criteria for the Min and Max, you get the MinPoint and MaxPoint properties. These two made me nervous when I first saw them, as you have to set them via their Modify methods, but that seems to work fine.

Sub SetRangeDataBar(rngTargetSection As Excel.Range, dbSource As Databar)
Dim dbTarget As Databar

Set dbTarget = rngTargetSection.FormatConditions.AddDatabar
With dbTarget
On Error Resume Next
.Formula = dbSource.Formula
On Error GoTo 0
With .AxisColor
.Color = dbSource.AxisColor.Color
.TintAndShade = dbSource.AxisColor.TintAndShade
End With
.AxisPosition = dbSource.AxisPosition
.BarBorder.Type = dbSource.BarBorder.Type
With .BarColor
.Color = dbSource.BarColor.Color
.TintAndShade = dbSource.BarColor.TintAndShade
End With
.BarFillType = dbSource.BarFillType
.Direction = dbSource.Direction
.MinPoint.Modify newtype:=dbSource.MinPoint.Type, newvalue:=dbSource.MinPoint.Value
.MaxPoint.Modify newtype:=dbSource.MaxPoint.Type, newvalue:=dbSource.MaxPoint.Value
.NegativeBarFormat.ColorType = dbSource.NegativeBarFormat.ColorType
With .NegativeBarFormat.Color
.Color = dbSource.NegativeBarFormat.Color.Color
.TintAndShade = dbSource.NegativeBarFormat.Color.TintAndShade
End With
.PercentMax = dbSource.PercentMax
.PercentMin = dbSource.PercentMin
.ShowValue = dbSource.ShowValue = True
End With
End Sub

There’s a whole bunch of properties besides MinPoint and MaxPoint. About half deal with formatting, including formatting of negative values. All of these are analogous to their similarly-named user interface properties:

Deleting Selected FormatConditions

I wrote a routine to delete only certain types of format conditions from a target range. It gets called before the routine to copy the formats. For example, if the routine is copying DataBar formats, we’ll first delete all the existing ones.

It took longer than I expected to get a workable routine, chiefly because my initial attempts were inpossibly slow. Whereas copying all three types of FormatCondition to 1000 rows takes about a second, deleting formats by looping through the whole FormatConditions collection was taking minutes.

The solution was to break the target range into little ranges of 10 rows each and delete the matching conditions from those ranges. I assume this must simplify Excel’s internal indexing of the FormatConditions collection, whatever that means :). This only takes a couple of seconds for a thousand rows.

The other thing to note is that you have to loop backwards through the FormatConditions – just like deleting any Excel object in a loop – or you’ll get a “Subscript out of Range” error:

Sub DeleteFormatConditions(rngTarget As Excel.Range, _
DeleteColorScales As Boolean, DeleteDataBars As Boolean, DeleteIconSets As Boolean)
Dim FormatConditionsCount As Long
Dim DeleteIncrement As Long
Dim DeleteRangeStart As Long
Dim DeleteRangeEnd As Long
Dim DeleteDone As Boolean
Dim rngDelete As Excel.Range
Dim objFormatCondition As Object
Dim i As Long

'Break target range into smaller ranges, which makes deletion go many times faster!
DeleteIncrement = 10
DeleteRangeStart = 1
'Min to keep from going past end of target range
DeleteRangeEnd = Application.WorksheetFunction.Min _
(DeleteRangeStart + DeleteIncrement, rngTarget.Rows.Count)
Do While Not DeleteDone
'rngTarget.Parent is the worksheet
Set rngDelete = rngTarget.Parent.Range(rngTarget.Cells(DeleteRangeStart, 1), _
rngTarget.Cells(DeleteRangeEnd, rngTarget.Columns.Count))
FormatConditionsCount = rngDelete.FormatConditions.Count
'Check each format condition's type and call matching routine
'Step backwards or risk "Subscript out of Range"
For i = FormatConditionsCount To 1 Step -1
Set objFormatCondition = rngDelete.FormatConditions(i)
If DeleteColorScales And objFormatCondition.Type = 3 Then
objFormatCondition.Delete
End If
If DeleteDataBars And objFormatCondition.Type = 4 Then
objFormatCondition.Delete
End If
If DeleteIconSets And objFormatCondition.Type = 6 Then
objFormatCondition.Delete
End If
Next i
If DeleteRangeEnd >= rngTarget.Rows.Count Then
DeleteDone = True
End If
DeleteRangeStart = Application.WorksheetFunction.Min _
(DeleteRangeStart + DeleteIncrement, rngTarget.Rows.Count)
DeleteRangeEnd = Application.WorksheetFunction.Min _
(DeleteRangeEnd + DeleteIncrement, rngTarget.Rows.Count)
Loop
End Sub

The Formula Property

As I mentioned above, each of these FormatConditions has a Formula property. I don’t see a match for this property anywhere in the Excel user interface. According to MSDN, it:

Returns or sets a String representing a formula, which determines the values to which the data bar will be applied.

This property is useful to limit the range of values that will display the conditional format. A typical scenario is when you have a range of numbers containing both positive and negative values. You may want to create more than one conditional format for this range of numbers—one for positive values and another for negative values.

Sure enough, if I apply it to a DataBar definition, like so…

dbDataBar.Formula = "=A1 > -5"

… I get this formatting, where the DataBars are only applied to cells with values greater than negative 5:

If there is a way to do this in the user interface, please let me know!

Miscellaneous:

In my previous post on this, I noted that a recorded macro sets the added conditional format to the first priority and that I was doing the same in my code. However, that’s a bad idea. When copying more than one format it will rearrange their order.
If you are fooling around with this stuff, you’ll notice that recording a macro that modifies existing conditional formatting produces all the code for that formatting, not just for the modification. This can be annoying or useful, depending.
The StopIfTrue FormatConition doesn’t apply to these three objects. You can see that they are grayed out in the Excel dialog.
The ScopeType and PTCondition properties have to do with conditional formatting in pivot tables.

Download!

Here’s a workbook with a working model and all the code.

Conditional Formatting Per-Row Color Scales

Posted on February 3, 2013 by Doug Glancy

If you want to compare all the numbers in a range, you can apply a conditional formatting color scale to the entire area and it works just fine. However, sometimes I want to compare the data on a per-row basis. Here’s two examples of data that could use per-row color scales:

The first, above, mixes values and percents. All the percents are red – the low end of the scale – because they equate to numbers between 0 and 1, and they’re getting compared to sales values between 1 and 100.

The second mixes sales from a large and small business. The sales for the small business are all shown as low – red – because they’re generally less than 1/100th of the sales of the large corporation.

In both cases I just want to compare the cells in each row to each other. Doing that, the second example looks like this, showing the relative sales within the company and year:

VBA to Apply Per-Row Color Scales

As far as I can tell, there’s no quick built-in way to apply color-scales (or icon sets or data bars) on a per-row basis. Instead you need to apply them one row at a time. So, of course, I wrote some VBA.

I’ve long been intimidated by Excel 2010’s conditional formatting object model, at least when it comes to non-formula conditions. But one day I answered this StackOverflow post about per-row color scales and decided to dig deeper.

For that answer I turned on the Macro Recorder, applied a color scale, and then called the generated code in a loop for each row. A better approach is to copy an existing row with the color scale you want and paste it over each row.

The simplest version of this is to copy all formatting in a source row and paste it to a target row. However, I’d prefer to grab only the color scale and paste it, ignoring other formats such as borders, text styles and other conditional formats.

If you turn on the Macro Recorder and apply a 3-gradient color scale to a range, you get something that looks like this, with the last five lines repeated two more times:

Selection.FormatConditions.AddColorScale ColorScaleType:=3
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).ColorScaleCriteria(1).Type = _
xlConditionValueLowestValue
With Selection.FormatConditions(1).ColorScaleCriteria(1).FormatColor
.Color = 7039480
.TintAndShade = 0
End With

Note that it adds a ColorScale and then moves it to the top of the conditional formatting stack with SetFirstPriority.

I discovered a quirk when I tried to modify the above code to do some simple looping through the conditional formatting settings in a range. I tried something like this:

Dim fc As FormatCondition
For Each fc In Selection.FormatConditions
Debug.Print fc.Application.Name
Next fc

That makes sense right? Set an object to a FormatCondition in order to loop through all the FormatConditions. However, if Selection only has color scale conditional formatting, you’ll get a “Type Mismatch” error on the “For Each fc” line. Turns out you need to declare fc as a ColorScale. Then the above code will run and will only cycle through the ColorScale objects.

So here’s the workhorse of my code. It’s called by the main module and loops through a target range, applying the color scale from the source range:

Sub SetRangeColorScale(rngTargetSection As Excel.Range, csSource As Excel.ColorScale)
Dim csTarget As ColorScale
Dim csCriterion As ColorScaleCriterion

Set csTarget = rngTargetSection.FormatConditions.AddColorScale(csSource.Type)
rngTargetSection.FormatConditions(rngTargetSection.FormatConditions.Count).SetFirstPriority
For Each csCriterion In csSource.ColorScaleCriteria
With csTarget.ColorScaleCriteria(csCriterion.Index)
.Type = csCriterion.Type
.FormatColor.Color = csCriterion.FormatColor.Color
.FormatColor.TintAndShade = csCriterion.FormatColor.TintAndShade
End With
Next csCriterion
End Sub

Below is my main routine. It allows you to choose Row or Column orientation, so you can paste the color scales by-column if you wish. The SectionIncrement variable specifies how many rows at a time to paste the color scale, so you could apply the comparison over two or more rows (or columns) at a time.

Note that in this module, objSourceCondition is declared as an object and tested to see if it’s a ColorScale type of FormatCondition:

Sub CopyColorScaleInSections()
Dim rngSource As Excel.Range
Dim rngTarget As Excel.Range
Dim ws As Excel.Worksheet
Dim objSourceCondition As Object 'we'll test for ColorScale
Dim rngTargetSection As Excel.Range
Dim FillDirection As String
Dim IncompatibleRangeError As String
Dim SectionIncrement As Long
Dim SectionsCount As Long
Dim i As Long

'change the settings below to suit
Set ws = ActiveSheet
Set rngSource = ws.Range("B2:E2")
Set rngTarget = ws.Range("B3:E7")
FillDirection = "Rows"
SectionIncrement = 1

'deletes all existing formats
'you might want to change to just delete
'ColorScales, but for demo purposes
'this works well
rngTarget.FormatConditions.Delete
'checks whether the settings above work together
If Not CompatibleRanges(rngSource, rngTarget, SectionIncrement, _
FillDirection, IncompatibleRangeError) Then
MsgBox IncompatibleRangeError, vbOKOnly + vbExclamation
GoTo exit_point
End If

'determine how many sections of rows or columns
'we'll be pasting over
If FillDirection = "Rows" Then
SectionsCount = rngTarget.Rows.Count / SectionIncrement
ElseIf FillDirection = "Columns" Then
SectionsCount = rngTarget.Columns.Count / SectionIncrement
End If

For i = 0 To SectionsCount - 1
'set an individual section to be pasted over
If FillDirection = "Rows" Then
Set rngTargetSection = rngTarget((i * SectionIncrement) + 1, 1) _
.Resize(SectionIncrement, rngTarget.Columns.Count)
ElseIf FillDirection = "Columns" Then
Set rngTargetSection = rngTarget(1, (i * SectionIncrement) + 1) _
.Resize(rngTarget.Rows.Count, SectionIncrement)
End If
For Each objSourceCondition In rngSource.FormatConditions
'test if it's a ColorScale - 3
If objSourceCondition.Type = 3 Then
SetRangeColorScale rngTargetSection, objSourceCondition
End If
Next objSourceCondition
Next i

exit_point:
End Sub

Obviously, when you do this you end up with a passel of conditional formatting rules, so don’t be surprised!

Here’s the function, called from the main routine above, that checks whether the source and target ranges are compatible:

Function CompatibleRanges(rngSource As Excel.Range, rngTarget As Excel.Range, _
SectionIncrement As Long, FillDirection As String, _
ByRef IncompatibleRangeError As String) As Boolean

'no #DIV/0
If SectionIncrement = 0 Then
IncompatibleRangeError = _
"You can't use an increment of 0"
GoTo exit_point
End If
'can't specify a SectionIncrement bigger than the target range
If (FillDirection = "Rows" And rngTarget.Rows.Count < SectionIncrement) Or _
(FillDirection = "Columns" And rngTarget.Columns.Count < SectionIncrement) Then
IncompatibleRangeError = _
"Target range must have at least" & vbCrLf & _
SectionIncrement & " rows."
GoTo exit_point
End If
'target range rows or columns must be
'evenly divisible by the SectionIncrement
If (FillDirection = "Rows" And rngTarget.Rows.Count Mod SectionIncrement <> 0) Or _
(FillDirection = "Columns" And rngTarget.Columns.Count Mod SectionIncrement <> 0) Then
IncompatibleRangeError = _
"Target range " & FillDirection & " must be" & vbCrLf & _
"evenly divisible by " & SectionIncrement & "."
GoTo exit_point
End If
'target range width or height has to match
'source range width or height
If Not (rngSource.Rows.Count = rngTarget.Rows.Count Or _
rngSource.Columns.Count = rngTarget.Columns.Count) Then
IncompatibleRangeError = _
"Source and Target ranges must have" & vbCrLf & _
"either the same number" & vbCrLf & "of rows or columns."
GoTo exit_point
End If

exit_point:
CompatibleRanges = IncompatibleRangeError = ""
End Function

I’ve run this code successfully on up to 10,000 rows. It took about 7 seconds. I did notice that deleting 9,900 of those rows afterwards takes a while, and that the workbook can then act sluggish until it’s saved. I’m not sure what the issue is.

No download right now, but I’m planning to whip up a workbook that expands this to IconSets and DataBars and whatever else I can cram in there. So look for that in a week or so.

Hide Pivot Table Single-Item Subtotals

Posted on November 28, 2012 by Doug Glancy

This pivot table looks awkward. The countries without provinces have a lone detail line, followed by a subtotal line with the exact same information. You can fix this by collapsing the single-item rows one at a time, but that’s time-consuming, and boring. Wouldn’t it be much more fun to write some code to hide pivot table single-item subtotals?

A year or so ago I did just that. In reviewing it for this post I cleaned it up and learned a few things about where it works and where it doesn’t. When I run it the result looks like this, with the duplicated population counts nicely hidden:

The heart of the code is this simple routine. You pass it a single PivotField and it hides the details for any item in that field that contains just one row:

Sub ProcessPivotField(pvtField As Excel.PivotField)
Dim ptItem As Excel.PivotItem

For Each ptItem In pvtField.PivotItems
If ptItem.RecordCount > 1 Then
ptItem.ShowDetail = True
Else
ptItem.ShowDetail = False
End If
Next ptItem
End Sub

In my first version of this code I used ptItem.DataRange.Rows.Count. This caused errors with hidden items, because their DataRange is Nothing. With ptItem.RecordCount it just sails on through.

The main procedure checks whether the cursor is in a pivot table and a few things like that. It then calls a function that returns only the visible pivot table row and column fields:

Function GetPivotFieldNames(pvtTable As Excel.PivotTable) As String()
Dim PivotFieldNames() As String
Dim pvtField As Excel.PivotField
Dim i As Long
Dim PivotFieldsCount As Long

PivotFieldsCount = 0
With pvtTable
ReDim Preserve PivotFieldNames(1 To .PivotFields.Count)
For i = LBound(PivotFieldNames) To UBound(PivotFieldNames)
Set pvtField = .PivotFields(i)
If pvtField.Orientation = xlColumnField Or _
pvtField.Orientation = xlRowField Then
PivotFieldsCount = PivotFieldsCount + 1
PivotFieldNames(PivotFieldsCount) = pvtField.Name
End If
Next i
End With
ReDim Preserve PivotFieldNames(1 To PivotFieldsCount)
GetPivotFieldNames = PivotFieldNames
End Function

The returned pivot fields are passed to a userform not unlike this one, except that it allows you to pick multiple items. That way you can collapse more than one field at a time. (I don’t show the code here, but you can get it all from the download link at the end.)

The form looks like this:

Collapsing single-item rows works great for lists like this one of continents, countries and provinces, because if a country has no subdivisions there’s no further detail to show. It’s just Iceland.

Where it doesn’t make as much sense is with something like sales by year, month, week and date:

Even if you had sales in only one week in February, you’ll probably call it “week 6”, or “February 12 to 19”, or something. But when you collapse February that detail gets hidden.

Even more limiting is that you can’t collapse February for one year and leave it expanded for another. At least, I can’t find any way, either in VBA or in Excel. You either show a total for all your Februaries, or for none. In the example above it would be nice to hide the February 2012 total, but show it for 2013. If anybody knows a way to do that, please let us know.

To fool around with this for yourself you can download a workbook with a couple of sample pivots and the Single-Item Subtotal hider.

NOTE: I noticed a ways into this post that the population data is old. I tried to find something more recent, but didn’t come up with anything that had the provinces/states data. But it was nicely packaged in an Access database.

Preview Excel Custom Formats

Posted on September 16, 2012 by Doug Glancy

(Enter a format in column A and something in column B to preview the format.)

I was thinking of doing a simple post (hah!) on using Excel’s TEXT function to transform numbers to text, in order to match them to ID-type numbers from databases. One of my recurring work tasks is matching a host of possible school IDs from databases (text) to those in spreadsheets (numeric). I frequently use formulas like:

INDEX(tblFromCsv[School_Name],MATCH(TEXT(Numeric_ID,"0"),tblFromCsv[Text_Id],0))

Then recently a post here was featured on Chandoo’s site, along with some from other blogs – increasing my lifetime page views by about 30%. Searching his post for complimentary comments, I saw a couple along the lines of “Thanks for the great links, especially the one from Bacon Bits.”

Mike’s post is indeed a a beauty. It shows how to use custom number formats and create a percentage format like that shown in the first two rows of the interactive workbook above. It got me thinking about what formats you can specify in the TEXT function. It turns out anything you can enter as a custom format works for the TEXT’s Format argument, with very similar results. For example, this formula will format whatever’s in A1 with a format specified in B1:

=TEXT(A1,B1)

This got me thinking about creating a utility that shows the results of any custom format. Just like what you could get by using Excel’s custom format dialog or one line of VBA code, only a lot more work :). Although to be fair, Excel’s custom format dialog doesn’t show color:

The reason TEXT doesn’t show color is that Excel functions – native and user-defined – don’t change the format of a cell. TEXT may seem like it’s breaking that rule, but it just returns a string that mimics the specified formatting.

So, adding color without VBA became my ~~excuse~~ reason for creating this tool. To do so, I used conditional formatting and an additional 29 columns of formulas. You can check them out by scrolling right in the workbook above. (You can also download it by using the button at the bottom of the workbook.)

There are two general types of custom formats, so my first task was to determine which kind is being used. The first has four different conditions in the form:

Positive number formats; negative number formats; zero formats; text formats

You can use less than four conditions. If you use only one, negative numbers and zero will use the positive format. If you use two, then zeros get the positive format.

The second type of custom form is more free-form and allows you to enter two custom conditions, and corresponding formats, along with a third format that covers all conditions not met by the first two. The conditions are specified using comparison operators enclosed in brackets like “[=]” “[<>]” “[>]”, etc. The form is:

1st condition and formats; 2nd condition and formats; formats for unmet conditions

Rows 4 through 6 above have some examples. Keep in mind that these custom conditions are evaluated from left to right, and when one is met the evaluation stops, like a VBA If statement.

This Microsoft page has a good explanation of the conditional formats including both of these types.

Determining which of the two types is being is used pretty easy. If the format contains any comparison operators inside of brackets then “Has custom conditions” in column H is true. I used an array formula that searches the format for one of the operators listed in D15:D20:

{=IF($F2,SUM((ISERROR(SEARCH(main!$D$15:$D$20,main!A2))=FALSE)*1)>0,"")}

The rest of the 29 columns contain equally convoluted formulas that tease out the various conditions and whether they have associated colors. These are summarized in columns J:M and N:Q.

The conditional formatting uses COUNTIF. COUNTIF is the only function I know that understands comparison operators combined with numbers in a string. For example, if you have the numbers 1 to 10 in cells A1:A10 and “>5” in B1 you can do this:

So I ended up with a conditional format for each possible color, like this:

=INDEX(N2:Q2,MATCH(1,COUNTIF(B2,J2:M2),0))="[Red]"

It’s an array formula, but for some reason in conditional formatting you don’t have to enter them with Shft-Ctrl-Enter and you don’t get the curly brackets. If anybody knows how conditional formatting recognizes array formulas, I’d like to hear.

I know of two things that don’t work correctly in this tool:

Text is sometimes colored when it shouldn’t be. If a text color isn’t explicitly implied it should not be changed, unless the general format is used for the positive condition. With this tool it uses the positive condition format in all cases.
If you put a color or custom condition, things that are enclosed in brackets, inside of quotes, this will still recognize them as colors or conditions. So don’t do that, at least for testing.

I could fix the first, but I’m not sure about the second. If you see any other failings, feel free to leave a comment.

I mentioned that this all could be done with one line of code. Assuming you have a number in A1 and format in B1, this line of code will apply the format to the number. Note that you need to format B1 as text so you can enter formats like 0000 – without quotes – and not have Excel convert them to a single zero.

Range("A1").NumberFormat = Range("B1")

I learned a ton from doing this, and now have a much more detailed understanding of custom formats. Have you done any projects that were less-than-practical, but rewarding?

Userform Application-Level Events

Posted on August 10, 2012 by Doug Glancy

I’ve been fooling around with workbook and application-level events in UserForms. I’ve put them to good use in one or two projects, so thought I’d post about it. While thinking about the best way to present it, I ended up with a form that allows you to track all application-level events in an Excel instance. EventTracker looks like this (click the pic to for bigger one):

Warning: meandering post ahead

Before we get to that though, here’s how you can create a simple form that responds to all SheetSelectionChange events. First add a userform to a workbook in the Visual Basic Editor, then add a textbox to it. Paste this code into the form’s code module:

Private WithEvents app As Excel.Application

Private Sub UserForm_Initialize()
Set app = Application
End Sub

Private Sub app_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Me.TextBox1 = Target.Address(external:=True)
End Sub

The code creates a WithEvents Application variable which is used to track application-level events. In this case, we’ll track the SheetSelectionChange event, but you can select other ones by selecting “app” in the dropdown at the top left of the VBA editor and the event in the dropdown at the top right.

Before you run the form you need to set its ShowModal property to False (or there will be no application-level events to track). Or you could just add this code to the code above:

Private Sub UserForm_Activate()
Static Activating As Boolean
If Activating = False Then
Activating = True
Me.Hide
Me.Show vbModeless
End If
End Sub

I didn’t know the above would work until I tried it here. I don’t recommend it for any kind of serious coding, because of the static variable, but I like it. Basically the code only runs the first time UserForm_Activate runs. It hides the form and then shows it again modally, obviating the need to set the ShowModal property in design time or open the form from another module.

Now run the form and you’ll see that every SelectionChange event is reflected in Textbox1.

So, back to the EventTracker form. It has two listboxes, one that shows all the available events to track, and one that lists the events that have occurred. You can set the events to track to all or none, or just some. The listbox is set to MultiSelectExtended, which means you can use Shift and Control to select ranges. I also added code so that Ctrl-A selects the whole list. Plus there’s option buttons!

The listbox that tracks events gets resized as they are added. (The form is resizable as well.) It shows the event and its parameters, such as the name of the worksheet being activated. I changed the parameters slightly, separating out the “Target” argument for the SheetPivotTableUpdate event into a “Pivot” column. The code that adds a row to the recent events uses a paramarray, which is the first time I’ve ever used one.

Here are some of the things I learned while making, and running, the form:

1. Even when the “After pressing enter, move selection” option is off, the SheetSelectionChange event fires after you edit a cell and hit Enter. Who knew?

2. There are a bunch of new events in Excel 2010. I only included “WorkbookAfterSave,” “WorkbookNewChart” and “SheetPivotTableAfterValueChange” in this tool. The rest have to do with Pivot table OLAP cubes.

3. There’s still no BeforeReallyClosing event though.

4. The maximum number of items allowed in a listbox is subject to available resources. On my laptop that equated to 6,242,685, so I didn’t need code to handle overfilling the event tracking listbox.

5. I discovered Chip Pearson’s excellent form resizing API code and used it to set the form with a minimize button and the ability to be resized.

One bit of code that’s useful on its own resizes column widths in a listbox. It’s based on this Daily Dose of Excel post, which in turn was based on a very thorough post by Jan Karel Pieterse. I modified Dick’s code to include the headers in the resizing, and also to base the the resizing only on the listbox’s visible rows:

Private Sub SetLstRecentEventsColumnWidths()

'Uses a hidden label in the form to hold
'text from headers and visible rows and
'resize to the widest one for each column

Dim ColWidths As String
Dim MaxWidth As Double
Dim i As Long
Dim j As Long
Dim VisibleRowsCount As Long
Dim HeaderLabels As Collection
Dim HeaderLabelWidths As Double

'create the HeaderLabels collection
Set HeaderLabels = GetHeaderLabels
With Me.lstRecentEvents
'skip the code if no rows yet
If .TopIndex > -1 Then
VisibleRowsCount = Application.WorksheetFunction.Min((.ListCount - .TopIndex) - 1, .Height / lblHidden.Height)
For i = 0 To .ColumnCount - 1
'first get the header label width
Me.lblHidden.Caption = HeaderLabels(i + 1) & "MM"
MaxWidth = Application.WorksheetFunction.Max(Me.lblHidden.Width, MaxWidth)
'only want to resize for the visible rows
For j = .TopIndex To .TopIndex + VisibleRowsCount
Me.lblHidden.Caption = .Column(i, j) & "MM"
MaxWidth = Application.WorksheetFunction.Max(Me.lblHidden.Width, MaxWidth)
Next j
ColWidths = ColWidths & CLng(MaxWidth + 1) & ";"
HeaderLabels(i + 1).Left = HeaderLabels(1).Left + HeaderLabelWidths
HeaderLabels(i + 1).Width = MaxWidth
HeaderLabelWidths = HeaderLabelWidths + CLng(MaxWidth + 1)
MaxWidth = 0
Next i
.ColumnWidths = ColWidths
End If
End With
End Sub

Back to the EventTracker form again. As my father might say “The road is the destination.” Or is it “kindling is fire…?”

The downloadable zip file has a grid showing the events handled and a handy button to start Event Tracker. The workbook is .xlsm format, because if it was saved in .xls then the more recent events wouldn’t be available. You can still run it in XL 2003 as long as you’ve installed the compatibility pack. When running in an earlier version than 2010, events not supported in that version show up in the form module under “General,” rather than under “app.”

Copy Numbers With Formatting to Strings

Posted on July 4, 2012 by Doug Glancy

The other day a co-worker needed to convert the formatted numbers in cells to text strings in the same cells – text strings that still looked like the formatted cells. For example, a cell with the number 12.34 formatted as a dollar amount would be converted to the string “$12.34”. The same number formatted for percent with two decimal points would become the string “1234.00%”. Formatted as a date, it would become the string “1/12/1900 8:09:36 AM”. In other words, he wanted text strings that contain what your eyes see in the formatted cell.

So that this… becomes that.

It’s subtle, but you can see that the converted cells are now left-aligned and many of them have the green triangle indicating “number stored as text.” And the ISNUMBER formula in D2 has switched from TRUE to FALSE.

My co-workder needed this because his worksheet was feeding an ArcGIS web-based map, with the cell values being used for interactive tables, or something like that. With formatted numbers in the cells, the tables would show 12.34 for the above examples. By converting the numbers to strings, the data were correctly formatted.

I don’t know of any way to do this without VBA. In Excel we are able to format cells as text, but if you just apply the Text format to numbers you lose the formatting. If you format target cells as Text and then copy your formatted source cells over them, the target cells assume the source cells’ formatting. Pasting as Values loses the formatting. Converting to a csv loses the formatting. So, I think VBA is required for this.

The VBA Range object has a Text property, which returns the contents of the cell as they appear to the human eye, exactly what we want. Using this property I was able to write a few lines of code and convert my co-worker’s spreadsheet:

Dim cell as Excel.Range
For Each cell In Selection
CellText = cell.Text
'@ is the Text format
cell.NumberFormat = "@"
cell.Value2 = CellText
Next cell

Since the number of cells was very small, this ran quickly and did what he wanted. The cells were now pushed into the interworld with their formatting intact.

Looping through cells as above is quite slow. Running it on 20,000 rows with 40,000 cells takes about 20 seconds on my laptop. Ideally, you want to assign all the cells to a variant array, process the elements of the array, and then plunk the array back into the range of cells.

I’ve done this with the Range object’s Value2 property before and wrote some code to do the same with Text. However, my variant array kept returning Null after doing something like:

Dim varCells as Variant
varCells = Selection.Text

I found this Charles Williams post where he points out that, unlike Value or Value2, assigning the Text property of a range to a variant array returns Null, unless all the cells have the same value and format.

So I changed the code to loop through the cells one at a time and assign their Text property to a two-dimensional String array. Fortunately, we can still assign the whole array back to a range.

Charles’ post revealed another interesting gotcha: when looping through cells’ Text properties and assigning them to an array your code gets progressively slower, but only if the range has rows with different heights in it. In my testing I noticed that even if all the rows are set back to the same height this weirdness persists.

The solution is to, every so often, select the cell that’s being processed. In my case, I chose to do it every 1000 rows. This won’t work if ScreenUpdating is set to False. This creates an additional reason to not process the cells one at a time, as all those writes back to the spreadsheet would slow things down even more.

(That’s a funky bug isn’t it? Makes you use Select in your code and leave Screenupdating on. I swear, when I started, I thought this would be a 400 word post! Nothing is simple in Excel, at least nothing I write about.)

One other issue is that if your columns are too narrow for a number and a cell is displaying “####”, the resulting text string will be “####”. I included a line in the code below to autofit the columns, but I’m not sure it will fix every situation.

With this code 20,000 rows with 40,000 cells takes about four seconds. This is only slightly worse than the three seconds it takes if the row heights are all the same and the Select fix isn’t needed, and much better than the 20 seconds if the row heights are different and Charles’ Select fix isn’t used.

Sub NumberToStringWithFormat(rng As Excel.Range)
Dim Texts() As String
Dim i As Long, j As Long

'This might prevent "###" if column too narrow
rng.EntireColumn.AutoFit
'Can't use variables in Dim
ReDim Texts(1 To rng.Rows.Count, 1 To rng.Columns.Count)
For i = 1 To rng.Rows.Count
'Charles' fix for slow code with Text
If i Mod 1000 = 0 Then
rng.Range("A1").Offset(i).Select
End If
For j = 1 To rng.Columns.Count
Texts(i, j) = rng.Cells(i, j).Text
Next j
Next i
'@ is the Text format
rng.NumberFormat = "@"
rng.Value2 = Texts
End Sub

Data Normalizer

Posted on March 28, 2012 by Doug Glancy

Sometimes I get data like this…

that needs to be like this…

The goal here is to roll up all the home runs into one, much longer, column. The data will then be pivot-worthy.

Generally, I need to keep one or more leftmost column headers, in this case “League” and “Year.” I need a new column to describe the rolled-up category (“Team”) and one for the data itself (“Home Runs”). I’ve written code a couple of times to handle specific cases and thought I’d try to generalize it. Here’s the result:

'Arguments
'List: The range to be normalized.
'RepeatingColsCount: The number of columns, starting with the leftmost,
' whose headings remain the same.
'NormalizedColHeader: The column header for the rolled-up category.
'DataColHeader: The column header for the normalized data.
'NewWorkbook: Put the sheet with the data in a new workbook?
'
'NOTE: The data must be in a contiguous range and the
'rows that will be repeated must be to the left,
'with the rows to be normalized to the right.

Sub NormalizeList(List As Excel.Range, RepeatingColsCount As Long, _
NormalizedColHeader As String, DataColHeader As String, _
Optional NewWorkbook As Boolean = False)

Dim FirstNormalizingCol As Long, NormalizingColsCount As Long
Dim ColsToRepeat As Excel.Range, ColsToNormalize As Excel.Range
Dim NormalizedRowsCount As Long
Dim RepeatingList() As String
Dim NormalizedList() As Variant
Dim ListIndex As Long, i As Long, j As Long
Dim wbSource As Excel.Workbook, wbTarget As Excel.Workbook
Dim wsTarget As Excel.Worksheet

With List
'If the normalized list won't fit, you must quit.
If .Rows.Count * (.Columns.Count - RepeatingColsCount) > .Parent.Rows.Count Then
MsgBox "The normalized list will be too many rows.", _
vbExclamation + vbOKOnly, "Sorry"
Exit Sub
End If

'You have the range to be normalized and the count of leftmost rows to be repeated.
'This section uses those arguments to set the two ranges to parse
'and the two corresponding arrays to fill
FirstNormalizingCol = RepeatingColsCount + 1
NormalizingColsCount = .Columns.Count - RepeatingColsCount
Set ColsToRepeat = .Cells(1).Resize(.Rows.Count, RepeatingColsCount)
Set ColsToNormalize = .Cells(1, FirstNormalizingCol).Resize(.Rows.Count, NormalizingColsCount)
NormalizedRowsCount = ColsToNormalize.Columns.Count * .Rows.Count
ReDim RepeatingList(1 To NormalizedRowsCount, 1 To RepeatingColsCount)
ReDim NormalizedList(1 To NormalizedRowsCount, 1 To 2)
End With

'Fill in every i elements of the repeating array with the repeating row labels.
For i = 1 To NormalizedRowsCount Step NormalizingColsCount
ListIndex = ListIndex + 1
For j = 1 To RepeatingColsCount
RepeatingList(i, j) = List.Cells(ListIndex, j).Value2
Next j
Next i

'We stepped over most rows above, so fill in other repeating array elements.
For i = 1 To NormalizedRowsCount
For j = 1 To RepeatingColsCount
If RepeatingList(i, j) = "" Then
RepeatingList(i, j) = RepeatingList(i - 1, j)
End If
Next j
Next i

'Fill in each element of the first dimension of the normalizing array
'with the former column header (which is now another row label) and the data.
With ColsToNormalize
For i = 1 To .Rows.Count
For j = 1 To .Columns.Count
NormalizedList(((i - 1) * NormalizingColsCount) + j, 1) = .Cells(1, j)
NormalizedList(((i - 1) * NormalizingColsCount) + j, 2) = .Cells(i, j)
Next j
Next i
End With

'Put the normal data in the same workbook, or a new one.
If NewWorkbook Then
Set wbTarget = Workbooks.Add
Set wsTarget = wbTarget.Worksheets(1)
Else
Set wbSource = List.Parent.Parent
With wbSource.Worksheets
Set wsTarget = .Add(after:=.Item(.Count))
End With
End If

With wsTarget
'Put the data from the two arrays in the new worksheet.
.Range("A1").Resize(NormalizedRowsCount, RepeatingColsCount) = RepeatingList
.Cells(1, FirstNormalizingCol).Resize(NormalizedRowsCount, 2) = NormalizedList

'At this point there will be repeated header rows, so delete all but one.
.Range("1:" & NormalizingColsCount - 1).EntireRow.Delete

'Add the headers for the new label column and the data column.
.Cells(1, FirstNormalizingCol).Value = NormalizedColHeader
.Cells(1, FirstNormalizingCol + 1).Value = DataColHeader
End With
End Sub

You’d call it like this:

Sub TestIt()
NormalizeList ActiveSheet.UsedRange, 2, "Team", "Home Runs", False
End Sub

It runs pretty fast. The sample sheet above – 109 years of data by 16 teams – completes instantly. 3,000 rows completes in a couple of seconds.

If I also run the routine on some American League data and put all the new rows in one sheet (with the same column headers) I can generate a pivot table that looks like this, which I couldn’t have done with the original data:

You can download a zip file with a .xls workbook that contains the data and code. Just click on the “normalize” button.