» Excel VBA (часть 3)

andrewkard1980
Вроде как для такой задачи Regular Expressions так и просятся. Только не спрашивайте меня как это сделать в Excel

andrewkard1980
Частично pattern настроил, детали можно посмотреть здесь

Код:
'подключить Microsoft VBScript Regular Expressions 5.5
Dim pReg As New VBScript_RegExp_55.RegExp
Dim pAnswers As VBScript_RegExp_55.MatchCollection

pReg.Global = True: pReg.Pattern = "\d+-\d+-\d+|\d+|\(\d+\)-\d+-\d+-\d+"

Set pAnswers = pReg.Execute("Вера Николаевна т.221-14-39, 0958723695, 0673079412.")
If pAnswers.Count > 0 Then
Debug.Print pAnswers.Item(0).Value
End If

Set pAnswers = pReg.Execute("Им'я: Вячеслав Телефон: 0979122381, м. 33040-3")
If pAnswers.Count > 0 Then
Debug.Print pAnswers.Item(0).Value
End If

Set pAnswers = pReg.Execute("Ещё чей-то (063)-266-68-00, раб. 23-33-333 ")
If pAnswers.Count > 0 Then
Debug.Print pAnswers.Item(0).Value
End If

andrewkard1980

Цитата:

нужно из строки вытянуть первый номер телефона. Строки разные.

Пусть, например, требуется из всех значений, находящихся в столбце "A" получить первый номер телефона и поместить рядом в столбец "B". Можно так:

Код: Sub Main()
Dim i As Long, s As String, a(), b(), x
Set x = CreateObject("VBScript.RegExp"): x.Global = True
a = Range([A1], Cells(Rows.Count, 1).End(xlUp)).Value
ReDim b(1 To UBound(a, 1), 1 To 1): On Error Resume Next
For i = 1 To UBound(a, 1)
If a(i, 1) <> "" Then
s = Trim(Replace(a(i, 1), Chr(160), " ")): x.Pattern = "[^()0-9]"
b(i, 1) = Replace(Split(Trim(x.Replace(s, " ")), " ")(0), " ", "")
End If
Next
[B:B].NumberFormat = "@": [B1].Resize(UBound(b, 1)).Value = b
End Sub

AndVGri

Цитата:

"\d+-\d+-\d+|\d+|\(\d+\)-\d+-\d+-\d+"

Я думаю тут лучше быть конкретнее с количеством цифр (\d+ -> \d{n,m}). И "-" заменить на [\s-] или добавить отдельно pattern-ы с пробелами.

AndVGri
dmka
А как Ваш вариант справится с двумя последними примерами автора

Цитата:

067 605 56 27 221 63 17
221 63 17 067 605 56 27

Если считать, что один номер от другого отделен двойным (или более) пробелом, то предложенный мной вариант с этой задачей справится, так же, как и со всеми другими, представленными автором. А Ваш вариант, с методом Execute, требует существенной доработки.

andrewkard1980 правильно смотрел (как я его понял) - от первой цифпы вычленить блок тлф.
Не учитывается возможная первая открывающая скобка в коде - будет отброшена (в примере нет такого варианта с лидирующим кодом в скобках).
Никаких доп. библиотек.
Думаю, работать будет быстрее, чем вариант SAS888.
Надо как-то более грамотно корявое Case сформулировать. Оставил для [more=наглядности :)]

Код:
Sub sb_TestStr()
Dim i%, iB%, iE%
Dim sStr$(1 To 8)
sStr(1) = "Им'я: Вячеслав Телефон: 0979122381 "
sStr(2) = "раб. 587-72-43 ; (063)-266-68-00 "
sStr(3) = "Роман т.3837006 м.0935688864м.0964165605м.0994356448 "
sStr(4) = "Иван 0672992940 "
sStr(5) = "0677088425 Олег; 093-404-55-50 Оксана "
sStr(6) = "Вера Николаевна т.221-14-39, 0958723695, 0673079412. "
sStr(7) = "067 605 56 27 221 63 17 "
sStr(8) = "221 63 17 067 605 56 27 "
For i = 1 To 8
iB = fn_Pos(sStr(i), 1)
iE = fn_Pos(sStr(i), iB + 1)
Debug.Print "'" & Mid(sStr(i), iB, iE - iB) & "'"
Next
End Sub

Function fn_Pos(pStr$, pBgn%) As Integer
Dim i%
Dim tAsc As Byte
Dim bSpc As Boolean
Dim sSym$
For i = pBgn To Len(pStr)
tAsc = Asc(Mid(pStr, i, 1))
Select Case pBgn
Case 1
If tAsc >= Asc(0) And tAsc <= Asc(9) Then Exit For
Case Else
Select Case tAsc
Case Asc(0), Asc(1), Asc(2), Asc(3), Asc(4), _
Asc(5), Asc(6), Asc(7), Asc(8), Asc(9), _
Asc("("), Asc(")"), Asc("-")
bSpc = False
Case Asc(" ")
If bSpc Then Exit For
bSpc = True
Case Else
Exit For
End Select
End Select
Next
fn_Pos = i + CInt(bSpc)
End Function

Ребят, спасибо. Не ожидал стольких решений. Буду пробовать.

SAS888

Цитата:

А как Ваш вариант справится с двумя последними примерами автора

Я не проверял, но если "-" заменить на [\s-] (пробел или минус) по идее должен справится. Или можно добавить такой-же pattern с пробелами.

Тупой regexp знающему синтаксис человеку кажется проще и гибче, хотя порой такого можно наворотить... Может в данном случае Ваше решение будет лучше. Пускай дальше автор вопроса разбирается и проверяет на реальных данных

asbo
Спасибо! Работает.

andrewkard1980, я рад.
Тогда, если концепция понятна, то можно часть кода заменить на:

Код:
Case 1
If (tAsc >= 48 And tAsc <= 57) Then Exit For
Case Else
Select Case tAsc
Case 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 40, 41, 45
bSpc = False
Case 32

Подскажите, как сделать, чтобы при открытии документа в определенную ячейку определенного листа (название известно) сразу же подставлялась текущая дата?

Zloy_Gelud,

внести в нее '=ТДАТА()' или '=СЕГОДНЯ()'
Но это значение будет каждый раз меняться открытии и пересчете.

Или же вставить модуль и в нем процедуру:
Private Sub Auto_Open()
Cells(1, 1) = Now()
End Sub

Или же использовать событие книги
Private Sub Workbook_Open()
Cells(1, 1) = Now()
End Sub

asbo -- спасибо. Подскажи еще. Вот допустим имеем мы некую ячейку. В ней нет абсолютно никакого текста. Так почему не работает такое:

Код: If IsEmpty(Range("A1")) Then
MsgBox ("Empty")
End If

Добрый день. Подаскажите, есть ли возможность в функции Split разделитель указать с разной длиной? Например, разбить строку на масив с разделителем <*>, при чем, вместо * может быть любая последовательность букв/цифр.
Спасибо!

Zloy_Gelud
По первому, думаю, что в A1 нечто все-таки есть. Попробуй проверь:

? "'" & Range("A1") & "'" или
? Asc(Range("A1"))
? Len(Range("A1"))

У меня, во всяком случае, и на пустой, еще девственной ячейке, и на той, из которой было удалено нечто, показывает True. И через Range("A1") и через Cells(1, 1)

Тут м.б. нюанс использовать или нет .Value, т.к. в твоем варианте идет обращение к объекту Range, у которого свойство по умолчанию - Value, которое и проверяется. Имо, в данном случае - пофиг, ибо Эксель. А вот если бы работали с таблицей Access - там поле может отзываться и на Empty, и на Null, и на "", в зависимости от того, что в нем есть или нет ваще ничего.

По второму - тут явная проверка значения на "". Она будет работать всегда, если в ячейке ничего нет.


Добавлено:
Да! Там может быть апостроф! "'" Chr(39)
Тогда в первом варианте будут всего _два_ апострофа, Len = 0, Ask даст ошибку 5, а Empty = False
Наверное в этом и дело.

(Я чуть поправил первый ? вызов)

Добавлено:
andrewkard1980
Не знаю. Хэлп говорит:


Цитата:

delimiter - Optional. String character used to identify substring limits. If omitted, the space character (" ") is assumed to be the delimiter. If delimiter is a zero-length string, a single-element array containing the entire expression string is returned.

Обрати внимание, что вначале используется "character" в единственном числе (string - прилагательное - строковый), а потом этот термин меняется на "string" (существительное), что подразумевает последовательность character-ов.

Вот и пойми. А говорят - курите маны... Как их курить, когда они своего же языка не знают... Да и ваще английский - ни тебе родов, ни тебе падежов. Написано - Манчестер, читается Ливерпуль.... Проверять надо.

Дык ты попробуй и расскажи :) Загони в строковую переменную нужную тебе последовательность, поставь ее в качестве аргумента - и вперед.

andrewkard1980
Используй всё тот же RegExp. Для примера (выделяет слова и целые числа)

Код:
'подключить Microsoft VBScript Regular Expressions 5.5
Dim pReg As New VBScript_RegExp_55.RegExp, pMatch As VBScript_RegExp_55.Match
Dim pMatches As VBScript_RegExp_55.MatchCollection

pReg.Global = True: pReg.Pattern = "[A-Za-zА-Яа-я0-9]*[^ \!-/:-\?\[-`\{-~$]": pReg.IgnoreCase = True
Set pMatches = pReg.Execute("Microsoft .Net 4, [to] (next) 54.47")
If pMatches.Count > 0 Then
For Each pMatch In pMatches
Debug.Print pMatch.Value
Next pMatch
End If

asbo

Цитата:

Никаких доп. библиотек.

Мой вариант использует позднее связывание. Т.е. ничего подключать не нужно.

Цитата:

Думаю, работать будет быстрее, чем вариант SAS888.

А я так не думаю. Выигрыш моего варианта во времени составляет примерно 30%.

dmka

Цитата:

если "-" заменить на [\s-] (пробел или минус) по идее должен справится

Возможно. Но не все так просто.

Цитата:

Или можно добавить такой-же pattern с пробелами.

Можно. Это как раз та доработка, о которой я говорил. Так, в одном из примеров автора есть строка, в которой между номерами телефонов вообще нет символа пробела (только другие), а двойной (и более) пробел нужно считать разделителем номеров, то, считаю, что в данном случае, все-таки более рационально использовать метод Replace объекта RegExp, чем Execute. Заменяем все символы, которые не может содержать телефонный номер (кстати, для приведения к одному виду, можно выбросить и "минус"), на пробелы и берем первую последовательность полученной строки до двух пробелов подряд. что у меня и сделано.

SAS888
* ничего подключать не нужно.
- А я говорил про другое - "Никаких доп. библиотек" Вы же сами процитировали :) Раннее-позднее... Какая разница? Библиотека нужна? Нужна. Ап чом тады речь?

Думаю... не думаю... устроили тут ромашка. Как-то конкретная величина 30 ну никак не вяжется с неопределенной преамбулой "не думаю". Замеряли? Тады так и говорите. А если только "думате" - не называйте конкрентных цифр :)

Я, это, не учу, не поймите превратно. Просто две фразы и два противоречия... Странные, однако, манеры изложения.

Мое "думаю" - всего лишь беглый взгляд на код. Померяю - скажу точно. И потом - это же _мой_ код! Он, по определению, должен работать быстрее :))
.

asbo
Моё "думаю" - это ответ на Ваше "думаю". А вообще-то, я утверждаю, т.к прежде, чем говорить, я все проверил...
Давайте прекратим флуд.

SAS888, друже, Вы уж тогда сами не начинайте флуд. А то сами флудите, а потом справедливо призываете к прекращению [more=оного.]

Моя к Вам просьба (на правах учавствующего в диалоге с Вами, и, соответственно, отстаивающего свои права): читайте _внимательно_ мои ответы. А еще внимательнее - свои ответы на мои посты. Извините за кроссквотинг, но если бы Вы начали с

"я утверждаю... я все проверил... что ... Выигрыш моего варианта во времени составляет примерно 30%. "

.., то и базара бы не было. А сечас, даже при взгляде мельком на ветку видно:

- Думаю, работать будет быстрее
- А я так не думаю
- Мое "думаю" - всего лишь беглый взгляд на код
- Моё "думаю" - это ответ на Ваше "думаю". А вообще-то, я утверждаю,
- Давайте прекратим флуд

Хохот душит...
[/more]

Добавлено:
SAS888,согласен. Давайте прекратим флуд. Тем более, что флудить, вобщем-то уже и не о чем.

Цитата:

Выигрыш моего варианта во времени составляет примерно 30%.

Мало того, что Вы ошиблись на порядок (!), но еще и знак попутали :) С точностью до наоборот.
Ваш код работает в 3 (ТРИ!) раза медленне моего.

Код:
asbo
1 ; Cycles: 10^1; Time, .....0, .......507
2 ; Cycles: 10^2; Time, .....0, .....5'058
3 ; Cycles: 10^3; Time, ....47, ....51'500
4 ; Cycles: 10^4; Time, ...531, ...521'237
5 ; Cycles: 10^5; Time, .5'187, .5'187'249
6 ; Cycles: 10^6; Time, 51'922, 51'929'215 (ужЕ неинтересно)
Cycles: 1000000= 10^6; Time, ms: 51'922, mcs: 51'929'215

888
1 ; Cycles: 10^1; Time, .....0, .....1'430
2 ; Cycles: 10^2; Time, ....16, ....14'676
3 ; Cycles: 10^3; Time, ...141, ...145'500
4 ; Cycles: 10^4; Time, .1'453, .1'443'293
5 ; Cycles: 10^5; Time, 14'453, 14'451'019
Cycles: 100000= 10^5; Time, ms: 14'453, mcs: 14'451'019

Подскажите пожалуйста, что значит ошибка во второй строчке "Runtime Error 9 Subscript Out of Range"? По каким причинам она возникает?



Код:
'постановка в очередь
W(minwind).kle = W(minwind).kle + 1
-->W(minwind).kl(W(minwind).kle) = iP

asbo

Цитата:

Ваш код работает в 3 (ТРИ!) раза медленне моего.

Вы, мягко говоря, ошибаетесь.
[more=Вот]Sub Ваш_код()
Dim i%, iB%, iE%
Dim sStr$(1 To 8)
sStr(1) = "Им'я: Вячеслав Телефон: 0979122381 "
sStr(2) = "раб. 587-72-43 ; (063)-266-68-00 "
sStr(3) = "Роман т.3837006 м.0935688864м.0964165605м.0994356448 "
sStr(4) = "Иван 0672992940 "
sStr(5) = "0677088425 Олег; 093-404-55-50 Оксана "
sStr(6) = "Вера Николаевна т.221-14-39, 0958723695, 0673079412. "
sStr(7) = "067 605 56 27 221 63 17 "
sStr(8) = "221 63 17 067 605 56 27 "
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim j As Integer
iTimer! = Timer
For j = 1 To 1000
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For i = 1 To 8
iB = fn_Pos(sStr(i), 1)
iE = fn_Pos(sStr(i), iB + 1)
Next
'''''''''''''''''''''''''''''''''''''''''''''''''''
Next
MsgBox "Время выполнения макроса составило " & _
Timer - iTimer! & " сек.", vbExclamation, ""
End Sub

Function fn_Pos(pStr$, pBgn%) As Integer
Dim i%
Dim tAsc As Byte
Dim bSpc As Boolean
Dim sSym$
For i = pBgn To Len(pStr)
tAsc = Asc(Mid(pStr, i, 1))
Select Case pBgn
Case 1
If tAsc >= Asc(0) And tAsc <= Asc(9) Then Exit For
Case Else
Select Case tAsc
Case Asc(0), Asc(1), Asc(2), Asc(3), Asc(4), _
Asc(5), Asc(6), Asc(7), Asc(8), Asc(9), _
Asc("("), Asc(")"), Asc("-")
bSpc = False
Case Asc(" ")
If bSpc Then Exit For
bSpc = True
Case Else
Exit For
End Select
End Select
Next
fn_Pos = i + CInt(bSpc)
End Function[/more] Ваш код.
А [more=Вот]Sub Мой_код()
Dim i As Long, s As String, a(1 To 8), b(), x
Set x = CreateObject("VBScript.RegExp"): x.Global = True
a(1) = "Им'я: Вячеслав Телефон: 0979122381 "
a(2) = "раб. 587-72-43 ; (063)-266-68-00 "
a(3) = "Роман т.3837006 м.0935688864м.0964165605м.0994356448 "
a(4) = "Иван 0672992940 "
a(5) = "0677088425 Олег; 093-404-55-50 Оксана "
a(6) = "Вера Николаевна т.221-14-39, 0958723695, 0673079412. "
a(7) = "067 605 56 27 221 63 17 "
a(8) = "221 63 17 067 605 56 27 "
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim j As Integer
iTimer! = Timer
For j = 1 To 1000
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

ReDim b(1 To UBound(a)): On Error Resume Next
For i = 1 To UBound(a, 1)
If a(i) <> "" Then
s = Trim(Replace(a(i), Chr(160), " ")): x.Pattern = "[^()0-9]"
b(i) = Replace(Split(Trim(x.Replace(s, " ")), " ")(0), " ", "")
End If
Next
'''''''''''''''''''''''''''''''''''''''''''''''''''
Next
MsgBox "Время выполнения макроса составило " & _
Timer - iTimer! & " сек.", vbExclamation, ""
End Sub[/more] мой.
Из Вашего макроса удален вывод сообщений, а из моего - вывод на рабочий лист.
Почувствуйте разницу.

Цитата:

Вы, мягко говоря, ошибаетесь.

Уж не намек ли это на то, что мне придется извиняться? :))

Вот участки кодов, которые [more=сравнивал я:]


Код:
For kk = 1 To 9
iB = fn_Pos(sStr(kk), 1)
iE = fn_Pos(sStr(kk), iB + 1)
sTest1 = Mid(sStr(kk), iB, iE - iB)
'''' Debug.Print kk; "'" & sTest1 & "'"
'''' Stop
Next

asbo

Цитата:

Да! Там может быть апостроф! "'" Chr(39)
Тогда в первом варианте будут всего _два_ апострофа, Len = 0, Ask даст ошибку 5, а Empty = False
Наверное в этом и дело.

Очень заинтересовали твои рассуждения. Давно, но безуспешно пытался написать макрос для удаления пустых строк и столбцов из таблицы (т.е. в которых все ячейки - не содержат видимых значений). Т.е. если там есть пробелы или невидимые апострофы (насколько я понял - это Chr(39)).
В связи с вышенаписанным вопрос: почему этот апостроф (если это вообще апостроф) не отображается в ячейке? Как определить какой символ или вообще - что именно - находится в ячейке?
Часто доводится играться с вот такими файлами.
Например, в первом столбце куча пустых (визуально) ячеек, только все они почему-то проверку на IsEmpty выдают False. Что в этих ячейках? Из-за подобных проблем не удается сделать корректную проверку на пустые строки и столбцы.
Буду благодарен за помощь.

mrdime,
* почему этот апостроф (если это вообще апостроф) не отображается в ячейке?
- дело в том, что в Экселе апостроф используется, в частности, для принудительной интерпретации им (Экселем) данных в ячейке, как текст, когда А расположен в начале строки. Ну, типа альтернатива форматированию ячейки как текст (@). И он не виден в этом случае.

* Как определить какой символ или вообще - что именно - находится в ячейке?
- Как показал эксперимент - и VBA его не видит... Надо еще поэкспериментировать на досуге. А может кто объявится и с готовым решением. На файлы взгляну обязательно к вечеру ближе.

* в первом столбце куча пустых (визуально) ячеек, только все они почему-то проверку на IsEmpty выдают False. Что в этих ячейках?
- я давным-давно решал подобную задачу. Времни было в обрез. Плюнул и решил ее на стадии шагом ранее - исключил попадание подобных данных в интересующие меня диапазоны листа :)

Цитата:

проверку на IsEmpty

А почему именно IsEmpty? Оно обязательно? Дает какие то преимущества или скорость вычислений повышает?
Почему так не сделать

Код: If Range("A9") = Empty then
Msgbox "empty"
End if

DmitryPrint
В примере asbo где-то было именно IsEmpty. Я и взял его за основу. Это не принципиально. Хотя могу предположить, что функции исполняются быстрее, чем произвольные логические действия. Но, это лишь мое ИМХО.

DmitryPrint,

*1 А почему именно IsEmpty?
- Тему читаем?

*2 Оно обязательно?
- Да

*3 Дает какие то преимущества ...
- Да (и см. п.1)

*4 ... или скорость вычислений повышает?
- А это тут при чем?

*5 Почему так не сделать
- Вот поэтому (и см п.1):

Range("A9").ClearContents
? Range("A9") = Empty
True
? IsEmpty(Range("A9"))
True
Range("A9") = "'"
? Range("A9") = Empty
True
? IsEmpty(Range("A9"))
False

Добавлено:
mrdime, да нет. У Zloy_Gelud и была изначально проверка на IsEmpty, только он сравнивал ее с ="", а не с = Empty

DmitryPrint :)
Да нет у нее никаких преимуществ. Другая функция просто. Какие преимущества опреации сложения перед операцией умножения?


Цитата:

видит там что-то внутреннее, да и черт с ней

Ну так и пользуйтесь. Если Вас устраивает результат, ко мне-то какие вопросы? Вы в очередной раз пытаетесь меня втянуть в дискуссию сравнения зеленого с кислым. Увольте...

А касательно условия, но которые Вы ссылаетесь, то (не в обиду никому) было мудро сказано "Ну если б мы им предоставили возможность что-либо решать, то..." :) (Что-то меня на классику пробило. Жизнь такая....)

Я это к тому, что если _буквально_ понимать условия задачи, то лучше уж тогда и не садиться за прграммирование.

Т.о. вот по этому условию
Цитата:

... удаления пустых строк и столбцов ... т.е. в которых все ячейки - не содержат видимых значений.

... при его формальном выполнении, будут удалено все, что содержит апострофы, пробелы, длинные пробелы, другие служебные символы, как то - конец строки, перевод строки etc. Даже если и есть данные, но с белым цветом шрифта - они будут удалены. Мало того, процесс удаления придется произвести _по_всему_ листу - сколько там в нем строк-столбцов. До физичиских его границ. Я это к тому, что произойдет, если формально подойти к решению поставленной задачи.

Цитата:

если формально подойти к решению поставленной задачи.

Ну это уж перебор. И потом VBA все-таки прикладной язык. Если некая задача решена - уже хорошо. Потом можно оптимизировать и улучшать и пр.

Насчет моего примера - да, может и не то поудалять, например формулы, если ссылка идет на пустые ячейки. Или если в ячейке ссылка на ячейку, которая имеет значение Empty.
Там надо все-таки использовать .Value и сравнивать с "".
Просто функцией IsEmpty вопрос не решается. Если ячейка как-то модифицировалась, то возвращается "", а не Empty.