Успешная обработка печально известных ошибок VBA (2042)!?
Перед использованием этого кода убедитесь, что вы тщательно изучили хотя бы раздел настройки, иначе вы можете потерять данные.
Самое главное, второй столбец долженвсегда находиться рядом с правой частью первого столбца, иначе этот код нельзя было бы сделать с помощью «версии для копирования и вставки массива».
@Melbee: я предполагаю, что у вас есть исходные данные в столбцах A ciFirstColи B iSecondCol = ciFirstCol + 1, и результат должен быть в столбце C cCOff 'if 1 then first column next to the second column.Если нет, внесите изменения в разделе настройки.
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
'-------------------------------------------------------------------------------
Кроме того, с точки зрения автоматизации для автоматического обновления ячеек, вы можете поместить следующий код в окно кода листов:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
XthColumnResult
End Sub
Идеальное решение должно быть сИзмените событие, но оно выдает «Ошибка времени выполнения 28: Недостаточно места в стеке», поэтому вместо этого я использовал событие SelectionChange.
Единственный недостаток, который я смог найти, заключался в том, что при удалении ячейки со значением «del» значениев третьем столбце не обновляется, прежде чем выйти из ячейки.
Как всегда, извините за «закомментирование».