Delete Matching Rows
Efficiency
- Using a sample of 20,000 rows in the source (read unique) and 200,000 records in the destination (delete matches) and 20 columns in both worksheets, this solution used between 5 and 15 seconds for 7167 unique 5-char strings and 85,036 deleted rows.
Module1
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In a column of a worksheet, compares the value of each cell
' with all values in a column of a worksheet in another workbook.
' If there is a match, the entire row of the first mentioned
' cell is deleted.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Calls:
' DeleteMatchingRows
' DictUniqueColumnFromThisWorkbook or DictUniqueColumnFromClosedWorkbook
' RefColumn
' GetColumnRange
' DictUniqueColumn
' RefTableRangeInThisWorkbook or RefTableRangeInClosedWorkbook
' RefCurrentRegionBottomRight
' ReplaceColumnDataMatchingInDict
' GetColumnRange
' ReplaceDataColumnMatchingInDict
' AutoFilterDeleteEntireRows
' GetColumnOfIntegers
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DeleteMatchingRows()
Const ProcName As String = "DeleteMatchingRows"
Dim IsSuccess As Boolean
On Error GoTo ClearError
' Time Passed
Dim tt As Double: tt = Timer ' Total Time
Dim t As Double: t = tt ' Time Per Operation
Dim tf As String: tf = "0.0000" ' Time Format
Dim tc As Double
' Source
Const sFilePath As String = "C:\Test\2021\70269924\FileA.xlsx"
Const swsName As String = "Sheet1" ' "Sheet2"
Const sfCellAddress As String = "H2"
Const sDictItem As Variant = Empty
Dim sDictCompareMode As VbCompareMethod: sDictCompareMode = vbTextCompare
' Note that if 'dIsThisWB = False' and 'sIsThisWb = True',
' the source workbook remains open regardlessly. 'sIsThisWb = True' is used
' for testing purposes or if both workbooks are 'ThisWorkbook'.
' In the latter case, don't forget to check that the worksheet names
' are different.
Const sIsThisWB As Boolean = False ' if 'True', 'sDoCloseWB' has no effect
Const sDoCloseWB As Boolean = True ' regardlessly changes will not be saved
' Destination
Const dFilePath As String = "C:\Test\2021\70269924\FileB.xlsx"
Const dwsName As String = "Sheet1"
Const dtrgFirstCellAddress As String = "A1"
Const dCriteriaCol As Long = 7 ' range column in this case 'G'
Const dFirstReplacementRow As Long = 2
' Be careful with the following three constants, there is no undo.
Const dIsThisWB As Boolean = False
Const dDoSaveWB As Boolean = False
Const dDoCloseWB As Boolean = False
' Other
Const Replacement As String = "!"
Debug.Print "Start '" & ProcName & "'... "
' 1.
Dim dict As Object
If sIsThisWB Then
Set dict = DictUniqueColumnFromThisWorkbook( _
swsName, sfCellAddress, sDictItem, sDictCompareMode)
tc = Timer
Debug.Print "1. DictUniqueColumnFromThisWorkbook... " _
& Format(tc - t, tf) & "(" & Format(tc - tt, tf) & ")": t = tc
Else
Set dict = DictUniqueColumnFromClosedWorkbook(sFilePath, swsName, _
sfCellAddress, sDictItem, sDictCompareMode, sDoCloseWB)
tc = Timer
Debug.Print "1. DictUniqueColumnFromClosedWorkbook... " _
& Format(tc - t, tf) & "(" & Format(tc - tt, tf) & ")": t = tc
End If
Debug.Print " Found " & dict.Count & " unique values."
' 2.
' Creates a reference to the destination workbook. If the destination
' workbook is the workbook containing this code then you have to set
' the constant 'dIsThisWB' to 'True'. If the destination workbook
' is a closed workbook, you have to set the constant to 'False' and
' appropriately set the 'dFilePath' constant for the workbook to open.
' Creates a reference to the destination table range.
Dim dtrg As Range
If dIsThisWB Then
Set dtrg = RefTableRangeInThisWorkbook(dwsName, dtrgFirstCellAddress)
tc = Timer
Debug.Print "2. RefTableRangeInThisWorkbook... " _
& Format(tc - t, tf) & "(" & Format(tc - tt, tf) & ")": t = tc
Else
Set dtrg = RefTableRangeInClosedWorkbook( _
dFilePath, dwsName, dtrgFirstCellAddress)
tc = Timer
Debug.Print "2. RefTableRangeInClosedWorkbook... " _
& Format(tc - t, tf) & "(" & Format(tc - tt, tf) & ")": t = tc
End If
Debug.Print " Created a reference to the table range '" _
& dtrg.Address(0, 0) & "'" & vbLf & " in the worksheet '" _
& dwsName & "' of the workbook '" _
& dtrg.Worksheet.Parent.Name & "'" & vbLf & " in the folder '" _
& dtrg.Worksheet.Parent.Path & "'."
' 3.
Dim dcrrg As Range: Set dcrrg = dtrg.Columns(dCriteriaCol)
ReplaceColumnDataMatchingInDict _
dcrrg, dict, Replacement, dFirstReplacementRow
Set dict = Nothing
Dim dcrCount As Long: dcrCount = Application.CountIf(dcrrg, Replacement)
tc = Timer
Debug.Print "3. ReplaceColumnDataMatchingInDict... " _
& Format(tc - t, tf) & "(" & Format(tc - tt, tf) & ")": t = tc
Debug.Print " Replaced cell values with '" & Replacement & "' in " _
& dcrCount & " rows."
If dcrCount = 0 Then ' already deleted
IsSuccess = True
GoTo ProcExit
End If
' 4.
AutoFilterDeleteEntireRows dtrg, Replacement, dCriteriaCol
tc = Timer
Debug.Print "4. AutoFilterDeleteEntireRows... " _
& Format(tc - t, tf) & "(" & Format(tc - tt, tf) & ")": t = tc
Debug.Print " Deleted " & dcrCount & " matching rows."
Dim dwb As Workbook: Set dwb = dtrg.Worksheet.Parent
' To close easily when testing, don't wanna delete for now
dwb.Saved = True
' When done testing, out-comment the previous line and adjust
' the 'dIsThisWB', 'dDoCloseWB' and 'dDoSaveWB' constants.
If Not dDoCloseWB Then ' save before 'IsSuccess' if not to be closed
If dDoSaveWB Then dwb.Save
End If
IsSuccess = True
ProcExit:
On Error GoTo ClearExitError
If IsSuccess Then
If Not dIsThisWB Then ' close before the message
If dDoCloseWB Then
dwb.Close SaveChanges:=dDoSaveWB
End If
End If
MsgBox "Rows deleted: " & dcrCount, vbInformation, ProcName
' If you close 'ThisWorkbook' before the message, you won't see it.
If dIsThisWB Then ' close after the message
If dDoCloseWB Then
dwb.Close SaveChanges:=dDoSaveWB
End If
End If
Else
MsgBox "Something went wrong." & vbLf _
& "See the message in the VBE Immediate window (Ctrl+G).", _
vbCritical, ProcName
End If
Debug.Print "End '" & ProcName & "'... "
FinalExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
ClearExitError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume FinalExit
End Sub
Module2
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the unique values, from a column range in the worksheet
' of a closed workbook, in the keys of a dictionary.
' Remarks: The default dictionary item ('DictItem') is 'Empty'.
' The default dictionary compare mode ('DictCompareMode')
' is 'vbTextCompare' i.e. 'A = a'.
' By default, closes the workbook not saving changes.
' Removes any filters, being relevant if the workboook stays open.
' Remarks: By default, closes the workbook not saving changes.
' Calls: 'RefColumn','GetColumnRange', and 'DictUniqueColumn'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictUniqueColumnFromClosedWorkbook( _
ByVal FilePath As String, _
ByVal WorksheetName As String, _
Optional ByVal FirstCellAddress As String = "A1", _
Optional ByVal DictItem As Variant = Empty, _
Optional ByVal DictCompareMode As VbCompareMethod = vbTextCompare, _
Optional ByVal DoCloseWorkbook As Boolean = True) _
As Object
Const ProcName As String = "DictUniqueColumnFromClosedWorkbook"
On Error GoTo ClearError
Dim wb As Workbook: Set wb = Workbooks.Open(FilePath)
Dim ws As Worksheet: Set ws = wb.Worksheets(WorksheetName)
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
Dim Data As Variant: Data = GetColumnRange(RefColumn(fCell))
Set DictUniqueColumnFromClosedWorkbook _
= DictUniqueColumn(Data, 1, DictItem, DictCompareMode)
If DoCloseWorkbook Then wb.Close SaveChanges:=False
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the unique values, from a column range in a worksheet
' of the workbook containing this code, 'Thisworkbook',
' in the keys of a dictionary.
' Remarks: The default dictionary item ('DictItem') is 'Empty'.
' The default dictionary compare mode ('DictCompareMode')
' is 'vbTextCompare' i.e. 'A = a'.
' Removes any filters.
' Calls: 'RefColumn','GetColumnRange', and 'DictUniqueColumn'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictUniqueColumnFromThisWorkbook( _
ByVal WorksheetName As String, _
Optional ByVal FirstCellAddress As String = "A1", _
Optional ByVal DictItem As Variant = Empty, _
Optional ByVal DictCompareMode As VbCompareMethod = vbTextCompare) _
As Object
Const ProcName As String = "DictUniqueColumnFromThisWorkbook"
On Error GoTo ClearError
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(WorksheetName)
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
Dim Data As Variant: Data = GetColumnRange(RefColumn(fCell))
Set DictUniqueColumnFromThisWorkbook _
= DictUniqueColumn(Data, 1, DictItem, DictCompareMode)
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Opens a workbook and for one of its worksheets,
' creates a reference to a table range (headers).
' Remarks: The workbook stays open and it can be referenced e.g. with
' ' Dim wb As Workbook: Set wb = rg.Worksheet.Parent'.
' Removes any filters.
' Calls: 'RefCurrentRegionBottomRight'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefTableRangeInClosedWorkbook( _
ByVal FilePath As String, _
ByVal WorksheetName As String, _
Optional ByVal FirstCellAddress As String = "A1") _
As Range
Const ProcName As String = "RefTableRangeInClosedWorkbook"
On Error GoTo ClearError
Dim wb As Workbook: Set wb = Workbooks.Open(FilePath)
Dim ws As Worksheet: Set ws = wb.Worksheets(WorksheetName)
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
Set RefTableRangeInClosedWorkbook = RefCurrentRegionBottomRight(fCell)
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In the workbook containing this code ('Thisworkbook'),
' for one of its worksheets, creates a reference
' to a table range (headers).
' Remarks: Removes any filters.
' Calls: 'RefCurrentRegionBottomRight'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefTableRangeInThisWorkbook( _
ByVal WorksheetName As String, _
Optional ByVal FirstCellAddress As String = "A1") _
As Range
Const ProcName As String = "RefTableRangeInThisWorkbook"
On Error GoTo ClearError
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(WorksheetName)
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
Set RefTableRangeInThisWorkbook = RefCurrentRegionBottomRight(fCell)
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Replaces the values in a column of a range, found
' in the keys of a dictionary, with a string.
' Remarks: Formulas in the column will be converted to values.
' Calls: 'GetColumnRange','ReplaceDataColumnMatchingInDict'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ReplaceColumnDataMatchingInDict( _
ByRef rg As Range, _
ByVal dict As Object, _
ByVal Replacement As String, _
Optional ByVal FirstReplacementRow As Long = 1, _
Optional ByVal ColumnNumber As Long = 1)
Const ProcName As String = "ReplaceColumnDataMatchingInDict"
On Error GoTo ClearError
Dim crg As Range: Set crg = rg.Columns(ColumnNumber)
Dim cData As Variant: cData = GetColumnRange(crg)
ReplaceDataColumnMatchingInDict _
cData, dict, Replacement, FirstReplacementRow
crg.Value = cData
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Filters a range on a string and deletes the entire rows
' of the filtered (visible) cells.
' Remarks: Removes any filters.
' Calls: 'GetColumnOfIntegers'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub AutoFilterDeleteEntireRows( _
ByVal TableRange As Range, _
ByVal FilterString As String, _
Optional ByVal FilterField As Long = 1)
Const ProcName As String = "AutoFilterDeleteEntireRows"
On Error GoTo ClearError
Dim ws As Worksheet: Set ws = TableRange.Worksheet
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim trrCount As Long: trrCount = TableRange.Rows.Count
Dim ntrcCount As Long: ntrcCount = TableRange.Columns.Count + 1 ' new
' Increase the table range by a column and create a reference to it.
Dim NewTableRange As Range
Set NewTableRange = TableRange.Resize(, ntrcCount)
' Write incrementing numbers to the new column.
With NewTableRange
With .Columns(ntrcCount) ' new last column
.Cells(1).Value = "C!!!" ' header
.Resize(trrCount - 1).Offset(1).Value _
= GetColumnOfIntegers(1, trrCount - 1) ' sequence of numbers
End With
' Sort the criteria column ascending to get all criteria strings
' one after the other to increase the effieciency of deleting rows
' since there will be only one range area i.e. a contiguous range.
.Sort .Columns(FilterField), xlAscending, , , , , , xlYes
' Create a reference to the data range, the new table range
' without headers. Do it before the auto-filtering.
Dim DataRange As Range: Set DataRange = .Resize(trrCount - 1).Offset(1)
.AutoFilter FilterField, FilterString ' with headers
' Create a reference to the filtered 'entire-row-range'
' ('DataVisibleRows') and delete it.
Dim DataVisibleRows As Range
On Error Resume Next
Set DataVisibleRows = DataRange _
.SpecialCells(xlCellTypeVisible).EntireRow
On Error GoTo ClearError
If Not DataVisibleRows Is Nothing Then DataVisibleRows.Delete
ws.AutoFilterMode = False
' Sort the new table range by its last column and clear it.
.Sort .Columns(ntrcCount), xlAscending, , , , , , xlYes
.Columns(ntrcCount).Clear
End With
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Sub
Module3
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
' Remarks: It is not safe to use it with merged cells and in filtered
' worksheets. Hidden rows or columns are allowed.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
Const ProcName As String = "RefColumn"
On Error GoTo ClearError
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Writes the values from a column ('ColumnNumber')
' of a range ('rg') to a 2D one-based one-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnRange( _
ByVal rg As Range, _
Optional ByVal ColumnNumber As Long = 1) _
As Variant
Const ProcName As String = "GetColumnRange"
On Error GoTo ClearError
With rg.Columns(ColumnNumber)
If rg.Rows.Count = 1 Then
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
GetColumnRange = Data
Else
GetColumnRange = .Value
End If
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the unique values, from a column ('ColumnIndex')
' of a 2D one-based array ('Data'), in the keys of a dictionary.
' The default dictionary item ('DictItem') is 'Empty'
' The default dictionary compare method ('DictCompareMethod')
' is 'vbTextCompare' i.e. 'A=a'.
' Remarks: Error and empty values are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictUniqueColumn( _
ByVal Data As Variant, _
Optional ByVal ColumnIndex As Long = 1, _
Optional ByVal DictItem As Variant = Empty, _
Optional ByVal DictCompareMode As VbCompareMethod = vbTextCompare) _
As Object
Const ProcName As String = "DictUniqueColumn"
On Error GoTo ClearError
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = DictCompareMode
Dim Key As Variant
Dim r As Long
For r = 1 To UBound(Data, 1)
Key = Data(r, ColumnIndex)
If Not IsError(Key) Then ' exclude error values
If Not IsEmpty(Key) Then ' exclude empty values
dict(Key) = DictItem
End If
End If
Next r
Set DictUniqueColumn = dict
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns a reference to the range from a cell ('FirstCell')
' to the last cell of its current region.
' Remarks: Useful when there is data (e.g. a title) adjacent
' to the top or to the left of a table range
' (obviously not allowed in an Excel table range).
' If the first cell is cell 'A1' or there is no adjacent data,
' it references the current region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegionBottomRight( _
ByVal FirstCell As Range) _
As Range
Const ProcName As String = "RefCurrentRegionBottomRight"
On Error GoTo ClearError
With FirstCell.Cells(1).CurrentRegion
Set RefCurrentRegionBottomRight = _
FirstCell.Resize(.Row + .Rows.Count - FirstCell.Row, _
.Column + .Columns.Count - FirstCell.Column)
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Compares the values in a column of a 2D one-based array ('Data')
' with the values in the keys of a dictionary ('dict')
' and replaces any matching values in the array,
' with a string ('Replacement').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ReplaceDataColumnMatchingInDict( _
ByRef Data As Variant, _
ByVal dict As Object, _
ByVal Replacement As String, _
Optional ByVal FirstReplacementRow As Long = 1, _
Optional ByVal DataColumn As Long = 1)
Const ProcName As String = "ReplaceDataColumnMatchingInDict"
On Error GoTo ClearError
Dim Key As Variant
Dim dr As Long
For dr = FirstReplacementRow To UBound(Data, 1)
Key = Data(dr, DataColumn)
If Not IsError(Key) Then
If Len(Key) > 0 Then
If dict.Exists(Key) Then
Data(dr, DataColumn) = Replacement
End If
End If
End If
Next dr
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns a sequence of integers
' in a 2D one-base one-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnOfIntegers( _
ByVal StartInteger As Long, _
ByVal EndInteger As Long, _
Optional ByVal StepInteger As Long = 1) _
As Variant
Const ProcName As String = "GetColumnOfIntegers"
On Error GoTo ClearError
Dim IsStepPositive As Boolean: IsStepPositive = (StartInteger <= EndInteger)
Dim siCount As Long
Dim drCount As Long
If IsStepPositive Then
siCount = EndInteger - StartInteger + 1
Else
siCount = StartInteger - EndInteger + 1
End If
Dim siStep As Long: siStep = Abs(StepInteger)
drCount = Int(siCount / siStep)
If siCount Mod siStep > 0 Then
drCount = drCount + 1
End If
If Not IsStepPositive Then
siStep = -siStep
End If
Dim dData() As Long: ReDim dData(1 To drCount, 1 To 1)
Dim si As Long
Dim dr As Long
For si = StartInteger To EndInteger Step siStep
dr = dr + 1
dData(dr, 1) = si
Next si
GetColumnOfIntegers = dData
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
