Excel VBA

This category will hold articles regarding developement in Excel VBA. It will serve as a wiki and an Excel VBA Framework for myself.

Some development tasks reoccur for every customer. Since I am a lazy bum it will be nice to have a central source where I can reuse source code from.

Handling of Date values can become very annoying. Especially, if Excel always thinks it knows better than the programmer or user *sigh*! Automation is meant to help people, not mess up their work.

In order to help me at least displaying date values in the correct format I implemented a little function to get a pattern string based on a users system locale settings.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
' @Author - Alexander Bolte
' @Change Date - 2013-12-14
' @Description - Determines the date format of the system the application is running on.
' The Excel application is getting the date seperator and the format of date values
' from the systems locale settings.
' @Returns - A String holding literals for Day (dd), Month (mm) and Year (yyyy)
' in the order corresponding the systems locale setting separated using the locales date separator.
Function getDateFormat() As String
    Dim dateFormat As String
    Dim datOrder As Integer
    Dim datSeparator As String
    
On Error GoTo err_handler:
    
    datOrder = Application.International(xlDateOrder)
    datSeparator = Application.International(xlDateSeparator)
    
    If datOrder = 0 Then
        dateFormat = "mm" & datSeparator & "dd" & datSeparator & "yyyy"
    ElseIf datOrder = 1 Then
        dateFormat = "dd" & datSeparator & "mm" & datSeparator & "yyyy"
    ElseIf datOrder = 2 Then
        dateFormat = "yyyy" & datSeparator & "mm" & datSeparator & "dd"
    End If
    
err_handler:
    If Err.Number <> 0 Then
        Err.Clear
    End If
    getDateFormat = dateFormat
End Function

The following methods provide you with three different ways of reading a range into a collection in VBA.

Source Code

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
Public Function readRangeIntoTableCollection(ByRef rng As Range, ByVal keyCol As Integer) As Scripting.Dictionary
    Dim i As Long
    Dim j As Integer
    Dim rec As Scripting.Dictionary
    Dim dict As New Scripting.Dictionary
    
    If Not (rng Is Nothing) Then
        If keyCol <> 0 Then
            ' Loop through all rows in a given range object.
            For i = 2 To rng.Rows.Count
                Set rec = New Scripting.Dictionary
                ' Loop through all columns in a given range object.
                For j = 1 To rng.Columns.Count
                    ' Read one record.
                    rec.Add rng.Cells(1, j).value, rng.Cells(i, j).value
                Next j
                ' Add one record to returned collection.
                dict.Add rng.Cells(i, keyCol).value, rec
            Next i
        End If
    End If
    
    Set readRangeIntoTableCollection = dict
End Function
 
' @Author - Alexander Bolte
' @ChangeDate - 2014-10-09
' @Description - Reading a provided Range objects values into a collection holding key value pairs.
' @Param rng - a Range object holding one or more columns.
' @Param keyCol - a column within provided Range holding keys.
' @Param valCol - a column within provided Range holding values.
' @Remarks - The index for columns starts in a provided Range, not in the worksheet.
' If for example the handed Range starts in column C of a worksheet
' and you need the first column of handed Range as keys, you would provide 1 and not 3 as keyCol.
Public Function readRangeIntoCollection(ByRef rng As Range, ByVal keyCol As Integer, ByVal valCol As Integer) As Scripting.Dictionary
    Dim i As Long
    Dim dict As New Scripting.Dictionary
    
    If Not (rng Is Nothing) Then
        If keyCol <> 0 And valCol <> 0 Then
            For i = 1 To rng.Rows.Count
                dict.Add rng.Cells(i, keyCol).value, rng.Cells(i, valCol).value
            Next i
        End If
    End If
    
    Set readRangeIntoCollection = dict
End Function
 
' @Author - Alexander Bolte
' @ChangeDate - 2014-10-09
' @Description - Reading a provided Range objects values into a collection.
' @Param rng - a Range object holding one column.
' @Returns a collection of type VBA.Collection holding all values
' from the first column in provided Range object.
Public Function readRangeIntoVbaCollection(ByRef rng As Range) As VBA.Collection
    Dim i As Long
    Dim dict As New VBA.Collection
    
    If Not (rng Is Nothing) Then
        For i = 1 To rng.Rows.Count
            If rng.Rows(i).Hidden = False Then
                dict.Add Trim(rng.Cells(i, 1).value)
            End If
        Next i
    End If
    
    Set readRangeIntoVbaCollection = dict
End Function

 

 

Excels behaviour can be quite annoying from time to time. One prime example is adjusting the row height of merged cells.

Normally you would think you can adjust the row height of a merged area the same way you adjust it for single cells.

Nope! No matter what you try it will not work properly.

However, below method can solve this issue partly for you. It will adjust the row height for a handed merged range of cells, but it only works for merged cells in one row. So, feel free to adjust this function to your needs and don't forget to share it with those who are in need ;0).

Source Code

' @Author - Alexander Bolte
' @Description - Adjusting the row height to content similar to Excel standard function for wrapping cell content.
' This method only works for merged cells accross one row.
' @Param rng - a Range object referencing a merged area.
Public Sub adjustRowHeightOfMergedCells(ByRef rng As Range)
Dim mergedWidth As Variant
Dim firstCell As Range
Dim newHeight As Double

If rng.MergeCells Then
mergedWidth = getColumnWidth(rng)
rng.MergeCells = False
Set firstCell = rng.Cells(1, 1)
firstCell.Columns.ColumnWidth = mergedWidth
firstCell.WrapText = True
firstCell.EntireRow.AutoFit
newHeight = firstCell.EntireRow.Height
rng.MergeCells = True
rng.Columns.ColumnWidth = (mergedWidth / rng.Columns.Count)
' Only adjust a rows height, if the current row height is smaller
' than the new height needed to display merged cells content properly.
If rng.Rows.EntireRow.RowHeight < newHeight Then
rng.Rows.EntireRow.RowHeight = newHeight
End If
End If
End Sub

Ok, now that we can adjust the row height of merged cells in Excel VBA, we have one question to answer.

How do I find merged cells?

The answer can be found in the source code below.

' @Author - Alexander Bolte
' @Description - Running through the columns of the handed range's parent worksheet used range,
' checking each cell in the first row of handed range for a valid MergedArea attribute
' and then returning the MergedArea.
' @Param srcRow - a Range object referencing a row in an Excel worksheet.
' @Param startCol - an Integer providing the start column from which a search for merged cells should begin.
Public Function getMergedCells(ByRef srcRow As Range, ByVal startCol As Integer) As Range
Dim ws As Worksheet
Dim testCell As Range
Dim merged As Range
Dim i As Integer

Set ws = srcRow.Parent
For i = startCol To ws.UsedRange.Columns.Count
Set testCell = ws.Cells(srcRow.Row, i)
Set merged = testCell.MergeArea
If merged.Columns.Count > 1 Then
Exit For
Else
Set merged = Nothing
End If
Next i

Set getMergedCells = merged
End Function

And how can you put both together? I prefer a method that uses recursion to run through the different columns in a given row but you can also run iteratively through the columns.

' @Author - Aleaxander Bolte
' @Description - Running recursively through an Excel row, adjusting the row height to all merged cells content, if the row height is not already greater than the new row height.
' @Param ws - a Worksheet object the change should be applied on.
' @Param trgRow - the target row the change should be applied on.
Private Sub adjustRowHeightToContent(ByRef ws As Worksheet, ByVal trgRow As Long)
Dim merged As Range

Set merged = xReusableCode.getMergedCells(ws.Rows(trgRow), 1)
' Stop condition for recursion.
If Not (merged Is Nothing) Then
' Adjust row height of merged cells.
Call adjustRowHeightOfMergedCells(merged)
' Call recursively.
Call adjustRowHeightToContent(ws, merged.Column + merged.Columns.Count - 1)
End If
End Sub

There you go, all done. Hope it helps, even if you only get a hint on how to do it yourself.