Имеются файлы (по количеству около 900 тыс.строк, объемы большие у всех файлов), там записан макрос, который при поиске нужной информации вставляет в свободный столбец номер мобильного телефона.
Т.е. в столбцах H и K есть данные, в столбец А вставляются каждый раз новые данные, при помощи макроса если есть совпадения ячейки А с H, то номер мобильного телефона из K копируется в столбец F.
Но возникла проблема: в столбце К присутствуют теперь номера какие-то со скобками, какие-то без, и коды городов тоже бывают и трехзначные и четырехзначные. И мне макрос выдает только мобильные номера, которые без скобок, а также еще городские номера.
Задача состоит в том, чтобы изменить макрос в соответствии с новыми данными, т.е. мне надо, чтобы в столбец F попадали только мобильные номера, никаких городских телефонов там не должно быть.
Очень прошу подсказать, как это сделать.
Файл-образец прикладываю и макрос отдельно тоже.
Макрос:
| Код |
|---|
Sub Telefon() Dim arr(), arr2(), Dic As Object, i&, iKey$ With Worksheets("Лист1") arr = .Range("H2:L" & .Cells(.Rows.Count, "K").End(xlUp).Row).Value Set Dic = CreateObject("Scripting.Dictionary"): Dic.comparemode = 1 For i = 1 To UBound(arr) Dic.Item(Trim(arr(i, 1)) & "|" & Trim(arr(i, 2)) & "|" & Trim(arr(i, 3))) = Trim(arr(i, 4)) Next arr = .Range("A2:C" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value ReDim arr2(1 To UBound(arr, 1), 1 To 1) For i = 1 To UBound(arr) iKey = Trim(arr(i, 1)) & "|" & Trim(arr(i, 2)) & "|" & Trim(arr(i, 3)) If Dic.exists(iKey) Then arr2(i, 1) = Telefon_sotov(Dic.Item(iKey)) End If Next .[F2].Resize(UBound(arr2), 1) = arr2 End WithEnd SubPublic Function Telefon_sotov(Text As String)Set objRegExp = CreateObject("VBScript.RegExp")objRegExp.Pattern = "\+7\s\d{3}\s\d{3}-\d{2}-\d{2}"objRegExp.Global = TrueStr1 = TextSet objMatches = objRegExp.Execute(Str1)For i = 0 To objMatches.Count - 1 If rez = "" Then rez = objMatches.Item(i) Else rez = rez & Chr(10) & objMatches.Item(i)NextTelefon_sotov = rezEnd Function |
