Handling the infamous VBA Errors (2042) successfully!?
Before using this code be sure you have studied at least the customize section carefully or you might lose data.
Most importantly the second column must always be adjacent to the right of the first column, otherwise this code couldn’t have been done with the ‘array copy-paste version’.
@Melbee: I am assuming you have your initial data in columns A
ciFirstCol
and B iSecondCol = ciFirstCol + 1 and the result should be in column C cCOff 'if 1 then first column next to the second column. If not make changes in the customize section.
Option Explicit
'-------------------------------------------------------------------------------
Sub XthColumnResult()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Description
'In an Excel worksheet uses two adjacent columns of initial data as arguments
'for a function whose result is pasted into a third column anywhere to the
'right of the two initial columns.
'(In short: 2 cols of data, perform calculation, result in third column)
'Arguments as constants
'cWbName
'The path of the workbook, if "" then ActiveWorkbook
'cWsName
'Name of the worksheet, if "" then ActiveSheet
'cloFirstRow
'First row of data
'ciFirstCol
'First column of data
'cCOff
'Column offset, where to paste the results into.
'Returns
'The resulting data in a new column to the right of the two initial adjacent
'columns of data.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'-- CUSTOMIZE BEGIN --------------------
Const cWbName As String = "" 'Workbook Path (e.g. "C:\MyExcelVBA\Data.xls")
Const cWsName As String = "" 'Worksheet Name (e.g. "Sheet1", "Data",... etc.
Const cloFirstRow As Long = 3 'First Row of Data
'Const cloLastRow as Long = Unknown >therefore> Dim loRow as Long
Const ciFirstCol As Integer = 1 'First Column of Data (1 for A, 2 for B etc.
'Second column of data must be adjacent to the right of first column.
'See iSecondCol. Therefore Dim iSecondCol As Integer
'Column offset where to paste the results into. Default is 1 i.e. the first
'column next to the second column.
Const cCOff As Integer = 1
'-- CUSTOMIZE END ----------------------
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Variables
Const cStrVBAError As String = "Error 20" 'Debug VBA Error Variable
Const cStrVBAErrorMessage As String = "Not Possible." 'Debug VBA Error Message
Dim oWb As Workbook
Dim oWs As Worksheet
Dim oRng As Range
Dim TheArray() As Variant
Dim SmallArray() As Variant
Dim loRow As Long 'Last Row of Data
Dim iSecondCol As Integer 'Second Column of Data
Dim iF1 As Integer 'Column Counter
Dim loArr As Long 'Array Row Counter
Dim iArr As Integer 'Array Column Counter
Dim str1 As String 'Debug String
Dim str2 As String 'Debug Helper String
Dim varArr As Variant 'Helper Variable for the Array
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Determine workbook and worksheet
If cWbName = "" Then
Set oWb = ActiveWorkbook
Else
Set oWb = Workbooks(cWbName)
End If
If cWsName = "" Then
Set oWs = oWb.ActiveSheet
Else
Set oWs = oWb.Worksheets(cWsName)
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Calculate second column of data
iSecondCol = ciFirstCol + 1
'Calculate last row of data (the greatest row of all columns)
loRow = 0
'Trying to translate the code to English:
'For each column go to the last cell and press crtl+up which is the last
'cell used in that column and use the row property...
For iF1 = ciFirstCol To iSecondCol
'...and check if it is greater than loRow.
If loRow < oWs.Cells(Rows.Count, ciFirstCol + iF1 - 1).End(xlUp).Row Then
'Assign the row to loRow (if it is greater than loRow).
loRow = oWs.Cells(Rows.Count, ciFirstCol + iF1 - 1).End(xlUp).Row
End If
Next
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Status
'The last row of data has been calculated. Additionally the first row, the
'first column and the second column will be the arguments of the following
'range (to be assigned to an array).
'Remarks
'When performing calculation, objects like workbooks, worksheets, ranges are
'usually very slow. To speed up, an array is introduced to hold the data
'and to calculate from there which is dozens of times faster.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Assign the range of data to an array.
TheArray = oWs.Range(Cells(cloFirstRow, ciFirstCol), Cells(loRow, iSecondCol))
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Status
'All data is now in TheArray ready for calculation.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' str1 = "Initial Contents in TheArray"
' For loArr = LBound(TheArray, 1) To UBound(TheArray, 1)
' For iArr = LBound(TheArray, 2) To UBound(TheArray, 2)
' If iArr > 1 Then
' str1 = str1 & Chr(9) 'Next Column
' Else 'First run-though.
' str1 = str1 & vbCrLf 'Next Row
' End If
' If Not IsError(TheArray(loArr, iArr)) Then
' str1 = str1 & TheArray(loArr, iArr)
' Else
' str1 = str1 & VbaErrorString(TheArray(loArr, iArr))
' End If
' Next
' Next
' Debug.Print str1
' str1 = ""
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Remarks
'A one-based array is needed to be pasted into the worksheet via range.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Create a new array for the resulting column.
ReDim SmallArray(LBound(TheArray) To UBound(TheArray), 1 To 1)
'Calculate values of the resulting column.
For loArr = LBound(TheArray, 1) To UBound(TheArray, 1)
'Read values from TheArray and calculate.
If IsError(TheArray(loArr, 1)) Then 'First column error
'VBA Error Handling, the result if both columns contain an error.
varArr = VbaErrorString(TheArray(loArr, 1))
Else
If IsError(TheArray(loArr, 2)) Then 'Second column error
'VBA Error Handling
varArr = VbaErrorString(TheArray(loArr, 2))
Else
If TheArray(loArr, 1) = "" Or TheArray(loArr, 2) = "" Then '""
varArr = "#N/A"
Else
Select Case TheArray(loArr, 1) 'Equal
Case TheArray(loArr, 2)
varArr = True
Case Is <> TheArray(loArr, 2) 'Not equal
varArr = False
Case Else
varArr = "UNKNOWN ERROR" 'Should never happen.
End Select
End If
End If
End If
'Write the results to SmallArray.
SmallArray(loArr, 1) = varArr
Next
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Status
'The resulting column containing the results has been written to SmallArray.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' str1 = "Resulting Contents in SmallArray"
' For loArr = LBound(SmallArray, 1) To UBound(SmallArray, 1)
' If Not IsError(SmallArray(loArr, 1)) Then
' str1 = str1 & vbCrLf & SmallArray(loArr, 1)
' Else
' 'VBA Error Handling
' str1 = str1 & vbCrLf & VbaErrorString(SmallArray(loArr, 1))
' End If
' Next
' Debug.Print str1
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Calculate the range where to paste the data,
Set oRng = oWs.Range(Cells(cloFirstRow, iSecondCol + 1), _
Cells(loRow, iSecondCol + 1))
'Paste the resulting column to worksheet.
oRng = SmallArray
' str1 = "Results of the Range"
' For loArr = 1 To oRng.Rows.Count
' If Not IsError(oRng.Cells(loArr, 1)) Then
' str2 = oRng.Cells(loArr, 1)
' Else
' 'VBA Error Handling
' str2 = VbaErrorCell(oRng.Cells(loArr, 1))
' End If
' str1 = str1 & vbCrLf & str2
' Next
' Debug.Print str1
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Status
'The resulting data has been pasted from SmallArray to the resulting
'column in the worksheet.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub
'-------------------------------------------------------------------------------
Function VbaErrorCell(rCell As Range) As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Description
'Converts a VBA error (variant) IN A RANGE to an Excel error value (string).
'Arguments
'rCell
'A cell range with a possible VBA error.
'If cell range contains more than one cell, the first cell is used.
'Returns
'An Excel error value (string) if the cell contains an error value, "" if not.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const cVErrLeft As String = "Error 20" 'Debug VBA Error Variable
Const cStrNewError As String = "New Error. Update this Function!"
Const cStrNoError As String = ""
''''''''''''''''''''''''''''''''''''''''
Dim strCStr As String 'The rCell Value Converted to a String
Dim strRes As String 'One of the Excel Cell Error Values
''''''''''''''''''''''''''''''''''''''''
strCStr = Left(CStr(rCell(1, 1)), Len(cVErrLeft))
If strCStr = cVErrLeft Then
Select Case Right(CStr(rCell), 2)
Case "00": strRes = "#NULL!"
Case "07": strRes = "#DIV/0!"
Case "15": strRes = "#VALUE!"
Case "23": strRes = "#REF!"
Case "29": strRes = "#NAME?"
Case "36": strRes = "#NUM!"
Case "42": strRes = "#N/A"
Case Else: strRes = cStrNewError 'New Error.
End Select
Else
strRes = cStrNoError 'Not a VBA Error
End If
VbaErrorCell = strRes
''''''''''''''''''''''''''''''''''''''''
End Function
'-------------------------------------------------------------------------------
Function VbaErrorString(strString As Variant) As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Description
'Converts a VBA error (variant) IN A STRING to an Excel error value (string).
'Arguments
'strString
'A string with a possible VBA Error.
'Returns
'An Excel error value (string) if the cell contains an error value, "" if not.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Const cVErrLeft As String = "Error 20" 'Debug VBA Error Variable
Const cStrNewError As String = "New Error. Update this Function!"
Const cStrNoError As String = ""
''''''''''''''''''''''''''''''''''''''''
Dim strCStr As String 'The strString Value Converted to a String
Dim strRes As String 'One of the Excel Cell Error Values
''''''''''''''''''''''''''''''''''''''''
strCStr = Left(CStr(strString), Len(cVErrLeft))
If strCStr = cVErrLeft Then
Select Case Right(CStr(strString), 2)
Case "00": strRes = "#NULL!"
Case "07": strRes = "#DIV/0!"
Case "15": strRes = "#VALUE!"
Case "23": strRes = "#REF!"
Case "29": strRes = "#NAME?"
Case "36": strRes = "#NUM!"
Case "42": strRes = "#N/A"
Case Else: strRes = cStrNewError 'New Error.
End Select
Else
strRes = cStrNoError 'Not a VBA Error
End If
VbaErrorString = strRes
''''''''''''''''''''''''''''''''''''''''
End Function
'-------------------------------------------------------------------------------
Additionally in view of automation to update the cells automatically, you might want to put the following code into the sheets code window:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
XthColumnResult
End Sub
The ideal solution should be with the Change event, but it throws the ‘Run-time error 28: Out of stack space’, so I used the SelectionChange event instead.
The only drawback I could find was that when you delete a cell with ‘del’ the value in the third column isn’t updated before you move out of the cell.
As always sorry for the ‘overcommenting’.
2
solved Calculating new cells containing True/False outputs from cells also containing #N/A values using VBA