Public Function io(ParamArray Arguments()) As Variant Dim v, x, i With CreateObject("VBScript.RegExp") .Global = True: .Pattern = "\d+" For Each v In Arguments For Each x In IIf(v.Count = 1, Array(v.Value), v.Value) i = i & " " & x Next Next Set x = .Execute(i): ReDim v(1 To x.Count) For i = 0 To x.Count - 1: v(i + 1) = CLng(x.Item(i).Value): Next io = v End With End Function
[/vba]
Кстати, ради интереса, можно потестить, что быстрее)
Цитата (v__step)
Это важнее!
v__step, ну раз важнее)))
[vba]
Код
Public Function io(ParamArray Arguments()) As Variant Dim v, x, i With CreateObject("VBScript.RegExp") .Global = True: .Pattern = "\d+" For Each v In Arguments For Each x In IIf(v.Count = 1, Array(v.Value), v.Value) i = i & " " & x Next Next Set x = .Execute(i): ReDim v(1 To x.Count) For i = 0 To x.Count - 1: v(i + 1) = CLng(x.Item(i).Value): Next io = v End With End Function
[/vba]
Кстати, ради интереса, можно потестить, что быстрее)nerv
Чебурашка стал символом олимпийских игр. А чего достиг ты? Тишина - самый громкий звук
Alex_ST, попробую объяснить, но с начала такой прикол
- при выделении нескольких ячеек создается массив - при выделении одной берется значение ячейки на строку ниже : )
[vba]
Код
Sub io() Dim x With Selection x = IIf(.Count = 1, .Offset(1), .Cells).Value End With End Sub
[/vba]
Цитата (Alex_ST)
никак не въеду: почему
В данном случае For Each это цикл по массиву. Т.е. For Each Variant In Array(): Next
Иными словами For Each x(сейчас x - это Object/Range) In IIf(x.Количество_Ячеек = 1, ПРАВДА:Создать_Массив_Из_Значения_Одной_Ячеки, ЛОЖЬ: создать массив из диапазона) А еще учти, что я на скорую руку шлепал и не тестил
Alex_ST, попробую объяснить, но с начала такой прикол
- при выделении нескольких ячеек создается массив - при выделении одной берется значение ячейки на строку ниже : )
[vba]
Код
Sub io() Dim x With Selection x = IIf(.Count = 1, .Offset(1), .Cells).Value End With End Sub
[/vba]
Цитата (Alex_ST)
никак не въеду: почему
В данном случае For Each это цикл по массиву. Т.е. For Each Variant In Array(): Next
Иными словами For Each x(сейчас x - это Object/Range) In IIf(x.Количество_Ячеек = 1, ПРАВДА:Создать_Массив_Из_Значения_Одной_Ячеки, ЛОЖЬ: создать массив из диапазона) А еще учти, что я на скорую руку шлепал и не тестил nerv
Чебурашка стал символом олимпийских игр. А чего достиг ты? Тишина - самый громкий звук
Вот, где собака порылась! Спасибо. Понял. Ты просто из одной ячейки так умудряешься сделать массив. Ну, тогда, наверное в завершение темы, выложу собранный и оформленный плод общего труда с обработкой ошибок [vba]
Код
Public Function ИЗВЛЕЧЬ_ЦЕЛЫЕ(ParamArray ДИАПАЗОН()) Dim rArea, rCell, sStr$, oMatches, i&, Arr() On Error GoTo xlErrEXIT For Each rArea In ДИАПАЗОН For Each rCell In IIf(rArea.Count = 1, Array(rArea.Value), rArea.Value) sStr = sStr & " " & rCell Next rCell Next rArea With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\d+": Set oMatches = .Execute(sStr): End With If oMatches.Count = 0 Then ИЗВЛЕЧЬ_ЦЕЛЫЕ = CVErr(xlErrNA): Exit Function ' вернуть ошибку #Н/Д если чисел нет ReDim Arr(1 To oMatches.Count) For i = 0 To oMatches.Count - 1: Arr(i + 1) = CLng(oMatches(i).Value): Next i ИЗВЛЕЧЬ_ЦЕЛЫЕ = Arr xlErrEXIT: If Err Then ИЗВЛЕЧЬ_ЦЕЛЫЕ = CVErr(xlErrValue): Exit Function ' вернуть ошибку #ЗНАЧЕНИЕ если была ошибка в аргументах End Function
[/vba]
P.S. Я не думаю, что применение тобой трёх переменных As Variant в "разных ипостасях" вместо примененных мною 6-ти, но более специализированных назначений как-то скажется на быстродействии, но зато код стал более читабельным
Цитата (nerv)
[vba]
Код
x = Array([A1].Value) ' 1 cell - array
[/vba]
Вот, где собака порылась! Спасибо. Понял. Ты просто из одной ячейки так умудряешься сделать массив. Ну, тогда, наверное в завершение темы, выложу собранный и оформленный плод общего труда с обработкой ошибок [vba]
Код
Public Function ИЗВЛЕЧЬ_ЦЕЛЫЕ(ParamArray ДИАПАЗОН()) Dim rArea, rCell, sStr$, oMatches, i&, Arr() On Error GoTo xlErrEXIT For Each rArea In ДИАПАЗОН For Each rCell In IIf(rArea.Count = 1, Array(rArea.Value), rArea.Value) sStr = sStr & " " & rCell Next rCell Next rArea With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\d+": Set oMatches = .Execute(sStr): End With If oMatches.Count = 0 Then ИЗВЛЕЧЬ_ЦЕЛЫЕ = CVErr(xlErrNA): Exit Function ' вернуть ошибку #Н/Д если чисел нет ReDim Arr(1 To oMatches.Count) For i = 0 To oMatches.Count - 1: Arr(i + 1) = CLng(oMatches(i).Value): Next i ИЗВЛЕЧЬ_ЦЕЛЫЕ = Arr xlErrEXIT: If Err Then ИЗВЛЕЧЬ_ЦЕЛЫЕ = CVErr(xlErrValue): Exit Function ' вернуть ошибку #ЗНАЧЕНИЕ если была ошибка в аргументах End Function
[/vba]
P.S. Я не думаю, что применение тобой трёх переменных As Variant в "разных ипостасях" вместо примененных мною 6-ти, но более специализированных назначений как-то скажется на быстродействии, но зато код стал более читабельным Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Понедельник, 21.11.2011, 17:02
Я никогда не понимал сути переменных, объявляемых As Byte…(ну самоучка я , поэтому с чем имел дело, то и знаю более-менее) Это что, целое от 0 до 255 или от -127 до 127?
Quote (nerv)
немного мозгового штурма
Quote (nerv)
As Byte
Я никогда не понимал сути переменных, объявляемых As Byte…(ну самоучка я , поэтому с чем имел дело, то и знаю более-менее) Это что, целое от 0 до 255 или от -127 до 127? Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Понедельник, 21.11.2011, 21:37
Я тут случайно полез к код функции "ИЗВЛЕЧЬ_ЦЕЛЫЕ" и обнаружил, что с обработкой ошибок перемудрил. Можно упростить так:[vba]
Код
Function ИЗВЛЕЧЬ_ЦЕЛЫЕ(ParamArray ДИАПАЗОН()) '--------------------------------------------------------------------------------------- ' Purpose : создать массив из целых чисел, извлечённых из текста произвольно расположенных ячеек ' Notes : К полученному массиву можно применять любые стандартные формулы листа ' Notes : Если цифр в ячейках-аргументах функции нет, то возвращается КОРРЕКТНОЕ #Н/Д '--------------------------------------------------------------------------------------- Dim rArea, rCell, sStr$, oMatches, i&, Arr() On Error GoTo xlErrEXIT For Each rArea In ДИАПАЗОН For Each rCell In IIf(rArea.Count = 1, Array(rArea.Value), rArea.Value) sStr = sStr & " " & rCell Next rCell Next rArea With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\d+": Set oMatches = .Execute(sStr): End With ReDim Arr(1 To oMatches.Count) For i = 0 To oMatches.Count - 1: Arr(i + 1) = CLng(oMatches(i).Value): Next i ИЗВЛЕЧЬ_ЦЕЛЫЕ = Arr xlErrEXIT: If Err Then ИЗВЛЕЧЬ_ЦЕЛЫЕ = CVErr(xlErrValue) ' вернуть ошибку #ЗНАЧЕНИЕ если была ошибка End Function
[/vba]
Я тут случайно полез к код функции "ИЗВЛЕЧЬ_ЦЕЛЫЕ" и обнаружил, что с обработкой ошибок перемудрил. Можно упростить так:[vba]
Код
Function ИЗВЛЕЧЬ_ЦЕЛЫЕ(ParamArray ДИАПАЗОН()) '--------------------------------------------------------------------------------------- ' Purpose : создать массив из целых чисел, извлечённых из текста произвольно расположенных ячеек ' Notes : К полученному массиву можно применять любые стандартные формулы листа ' Notes : Если цифр в ячейках-аргументах функции нет, то возвращается КОРРЕКТНОЕ #Н/Д '--------------------------------------------------------------------------------------- Dim rArea, rCell, sStr$, oMatches, i&, Arr() On Error GoTo xlErrEXIT For Each rArea In ДИАПАЗОН For Each rCell In IIf(rArea.Count = 1, Array(rArea.Value), rArea.Value) sStr = sStr & " " & rCell Next rCell Next rArea With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\d+": Set oMatches = .Execute(sStr): End With ReDim Arr(1 To oMatches.Count) For i = 0 To oMatches.Count - 1: Arr(i + 1) = CLng(oMatches(i).Value): Next i ИЗВЛЕЧЬ_ЦЕЛЫЕ = Arr xlErrEXIT: If Err Then ИЗВЛЕЧЬ_ЦЕЛЫЕ = CVErr(xlErrValue) ' вернуть ошибку #ЗНАЧЕНИЕ если была ошибка End Function
Оказывается, ещё чуть подпилил у себя, а сюда добавить забыл... Теперь если цифр нет, то вернёт ошибку #Н/Д как обычная функция листа.
[vba]
Код
Function ИЗВЛЕЧЬ_ЦЕЛЫЕ(ParamArray Диапазон()) '--------------------------------------------------------------------------------------- ' Author : Alex_ST, v__step, nerv ' URL : http://www.excelworld.ru/forum/3-1012-97065-16-1401961860 ' Topic : Функция (UDF) "ИЗВЛЕЧЬЦЕЛЫЕ" ' Purpose : Создать массив из целых чисел, извлечённых из текста произвольно расположенных ячеек ' Notes : К полученному массиву можно применять любые стандартные формулы листа '--------------------------------------------------------------------------------------- Dim rArea, rCell, sStr$, oMatches, i&, Arr() On Error GoTo xlErrEXIT For Each rArea In Диапазон For Each rCell In IIf(rArea.Count = 1, Array(rArea.Value), rArea.Value) sStr = sStr & " " & rCell Next rCell Next rArea With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\d+": Set oMatches = .Execute(sStr): End With If oMatches.Count = 0 Then ИЗВЛЕЧЬ_ЦЕЛЫЕ = CVErr(xlErrNA): Exit Function ' вернуть ошибку #Н/Д если чисел нет ' If oMatches Is Nothing Then ИЗВЛЕЧЬ_ЦЕЛЫЕ = CVErr(xlErrNA): Exit Function ' вернуть ошибку #Н/Д если чисел нет ReDim Arr(1 To oMatches.Count) For i = 0 To oMatches.Count - 1: Arr(i + 1) = CLng(oMatches(i).Value): Next i ИЗВЛЕЧЬ_ЦЕЛЫЕ = Arr xlErrEXIT: If Err Then ИЗВЛЕЧЬ_ЦЕЛЫЕ = CVErr(xlErrValue) ' вернуть ошибку #ЗНАЧ! если была ошибка End Function
[/vba]
Оказывается, ещё чуть подпилил у себя, а сюда добавить забыл... Теперь если цифр нет, то вернёт ошибку #Н/Д как обычная функция листа.
[vba]
Код
Function ИЗВЛЕЧЬ_ЦЕЛЫЕ(ParamArray Диапазон()) '--------------------------------------------------------------------------------------- ' Author : Alex_ST, v__step, nerv ' URL : http://www.excelworld.ru/forum/3-1012-97065-16-1401961860 ' Topic : Функция (UDF) "ИЗВЛЕЧЬЦЕЛЫЕ" ' Purpose : Создать массив из целых чисел, извлечённых из текста произвольно расположенных ячеек ' Notes : К полученному массиву можно применять любые стандартные формулы листа '--------------------------------------------------------------------------------------- Dim rArea, rCell, sStr$, oMatches, i&, Arr() On Error GoTo xlErrEXIT For Each rArea In Диапазон For Each rCell In IIf(rArea.Count = 1, Array(rArea.Value), rArea.Value) sStr = sStr & " " & rCell Next rCell Next rArea With CreateObject("VBScript.RegExp"): .Global = True: .Pattern = "\d+": Set oMatches = .Execute(sStr): End With If oMatches.Count = 0 Then ИЗВЛЕЧЬ_ЦЕЛЫЕ = CVErr(xlErrNA): Exit Function ' вернуть ошибку #Н/Д если чисел нет ' If oMatches Is Nothing Then ИЗВЛЕЧЬ_ЦЕЛЫЕ = CVErr(xlErrNA): Exit Function ' вернуть ошибку #Н/Д если чисел нет ReDim Arr(1 To oMatches.Count) For i = 0 To oMatches.Count - 1: Arr(i + 1) = CLng(oMatches(i).Value): Next i ИЗВЛЕЧЬ_ЦЕЛЫЕ = Arr xlErrEXIT: If Err Then ИЗВЛЕЧЬ_ЦЕЛЫЕ = CVErr(xlErrValue) ' вернуть ошибку #ЗНАЧ! если была ошибка End Function