Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Выборка по мобильным номерам телефонов - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Выборка по мобильным номерам телефонов (Макросы/Sub)
Выборка по мобильным номерам телефонов
Alina80 Дата: Вторник, 08.12.2020, 00:38 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Задача: Необходимо с помощью макроса вставить в свободный столбец из заполненных ячеек только мобильные номера телефонов, исключая городские.
Текст: Имеются файлы (по количеству около 900 тыс.строк, объемы большие у всех файлов), там записан макрос, который при поиске нужной информации вставляет в свободный столбец номер мобильного телефона.
Т.е. в столбцах H и K есть данные, в столбец А вставляются каждый раз новые данные, при помощи макроса если есть совпадения ячейки А с H, то номер мобильного телефона из K копируется в столбец F.
Но возникла проблема: в столбце К присутствуют теперь номера какие-то со скобками, какие-то без, и коды городов тоже бывают и трехзначные и четырехзначные. И мне макрос выдает только мобильные номера, которые без скобок, а также еще городские номера.
Задача состоит в том, чтобы изменить макрос в соответствии с новыми данными, т.е. мне надо, чтобы в столбец F попадали только мобильные номера, никаких городских телефонов там не должно быть.
Очень прошу подсказать, как это сделать.
Файл-образец прикладываю и макрос отдельно тоже.
[vba]
Код
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 With
End Sub

Public 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 = True
Str1 = Text
Set 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)
Next
Telefon_sotov = rez

End Function
[/vba]
К сообщению приложен файл: __--..xlsm (21.6 Kb)


Сообщение отредактировал Alina80 - Вторник, 08.12.2020, 12:08
 
Ответить
СообщениеЗадача: Необходимо с помощью макроса вставить в свободный столбец из заполненных ячеек только мобильные номера телефонов, исключая городские.
Текст: Имеются файлы (по количеству около 900 тыс.строк, объемы большие у всех файлов), там записан макрос, который при поиске нужной информации вставляет в свободный столбец номер мобильного телефона.
Т.е. в столбцах H и K есть данные, в столбец А вставляются каждый раз новые данные, при помощи макроса если есть совпадения ячейки А с H, то номер мобильного телефона из K копируется в столбец F.
Но возникла проблема: в столбце К присутствуют теперь номера какие-то со скобками, какие-то без, и коды городов тоже бывают и трехзначные и четырехзначные. И мне макрос выдает только мобильные номера, которые без скобок, а также еще городские номера.
Задача состоит в том, чтобы изменить макрос в соответствии с новыми данными, т.е. мне надо, чтобы в столбец F попадали только мобильные номера, никаких городских телефонов там не должно быть.
Очень прошу подсказать, как это сделать.
Файл-образец прикладываю и макрос отдельно тоже.
[vba]
Код
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 With
End Sub

Public 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 = True
Str1 = Text
Set 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)
Next
Telefon_sotov = rez

End Function
[/vba]

Автор - Alina80
Дата добавления - 08.12.2020 в 00:38
китин Дата: Вторник, 08.12.2020, 07:48 | Сообщение № 2
Группа: Модераторы
Ранг: Экселист
Сообщений: 7013
Репутация: 1073 ±
Замечаний: 0% ±

Excel 2007;2010;2016
Alina80, - Прочитайте Правила форума
- Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)


Не судите очень строго:я пытаюсь научиться
ЯД 41001877306852
 
Ответить
СообщениеAlina80, - Прочитайте Правила форума
- Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку #, пояснялка здесь)

Автор - китин
Дата добавления - 08.12.2020 в 07:48
gling Дата: Вторник, 08.12.2020, 19:42 | Сообщение № 3
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2519
Репутация: 674 ±
Замечаний: 0% ±

2010
подсказать, как это сделать.
2. Повторюсь: Обратитесь к автору макроса.
3. Обратитесь в раздел фриланс
4. Ждите когда у желающих появится интерес разобрать работу макроса и изменить под ваши "хотелки".
5. Преобразовать данные в вид для котрого написан этот макрос.
чтобы в столбец F попадали только мобильные номера
6. На мой взгляд всё так и происходит. Вы видите в столбце F номера со скобками или 4 цифры после +7 ? Я такие номера в столбце F не вижу.
Опишите конкретнее, вы что хотите и что вас не удовлетворяет? Покажите на данных которые обработал макрос, как он их обработал и как бы вы хотели бы чтобы он их обработал.


ЯД-41001506838083

Сообщение отредактировал gling - Вторник, 08.12.2020, 20:02
 
Ответить
Сообщение
подсказать, как это сделать.
2. Повторюсь: Обратитесь к автору макроса.
3. Обратитесь в раздел фриланс
4. Ждите когда у желающих появится интерес разобрать работу макроса и изменить под ваши "хотелки".
5. Преобразовать данные в вид для котрого написан этот макрос.
чтобы в столбец F попадали только мобильные номера
6. На мой взгляд всё так и происходит. Вы видите в столбце F номера со скобками или 4 цифры после +7 ? Я такие номера в столбце F не вижу.
Опишите конкретнее, вы что хотите и что вас не удовлетворяет? Покажите на данных которые обработал макрос, как он их обработал и как бы вы хотели бы чтобы он их обработал.

Автор - gling
Дата добавления - 08.12.2020 в 19:42
_Igor_61 Дата: Вторник, 08.12.2020, 22:42 | Сообщение № 4
Группа: Проверенные
Ранг: Ветеран
Сообщений: 504
Репутация: 90 ±
Замечаний: 0% ±

Excel 2007
мне надо, чтобы в столбец F попадали только мобильные номера, никаких городских телефонов там не должно быть

Чем чужой код разбирать проще свой написать :)
[vba]
Код
Sub Sotiki()
    Application.ScreenUpdating = False
    Dim r&, i&, s$, a
    r = Cells(Rows.Count, 1).End(xlUp).Row + 1
    a = Range(Cells(2, 1), Cells(r, 11))
For i = 1 To UBound(a)
    s = Mid(Cells(i, 11), 4, 1)
If a(i, 1) = a(i, 8) And s = "9" Then
    Cells(i, 6).Resize(1).Value = Mid(Cells(i, 11).Value, 1, 16)
End If
Next
    Application.ScreenUpdating = True
End Sub
[/vba]
Из ячеек с несколькими телефонами берется только первый, но это лучше чем вообще ничего, пробуйте на Ваших таблицах :)
К сообщению приложен файл: 9864052.xlsm (16.7 Kb)
 
Ответить
Сообщение
мне надо, чтобы в столбец F попадали только мобильные номера, никаких городских телефонов там не должно быть

Чем чужой код разбирать проще свой написать :)
[vba]
Код
Sub Sotiki()
    Application.ScreenUpdating = False
    Dim r&, i&, s$, a
    r = Cells(Rows.Count, 1).End(xlUp).Row + 1
    a = Range(Cells(2, 1), Cells(r, 11))
For i = 1 To UBound(a)
    s = Mid(Cells(i, 11), 4, 1)
If a(i, 1) = a(i, 8) And s = "9" Then
    Cells(i, 6).Resize(1).Value = Mid(Cells(i, 11).Value, 1, 16)
End If
Next
    Application.ScreenUpdating = True
End Sub
[/vba]
Из ячеек с несколькими телефонами берется только первый, но это лучше чем вообще ничего, пробуйте на Ваших таблицах :)

Автор - _Igor_61
Дата добавления - 08.12.2020 в 22:42
Alina80 Дата: Вторник, 08.12.2020, 23:56 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
_Igor_61, Спасибо огромное за помощь. Но, к сожалению, это не совсем подходит, т.к. всё-таки теряются мобильные номера из ячеек, кроме первых, а их там иногда очень много. Я решила эту проблему путем "найти-заменить". Отфильтровала, оставила скобки где мне надо (это городские номера), ну и потом воспользовалась своим макросом. Всё получилось идеально. Я думала, что можно какие-то правки внести в макрос, чтобы это автоматом было, но до сих пор никто не предложил никаких вариантов решения задач, так что немного пришлось вручную сделать.
Все равно спасибо.
 
Ответить
Сообщение_Igor_61, Спасибо огромное за помощь. Но, к сожалению, это не совсем подходит, т.к. всё-таки теряются мобильные номера из ячеек, кроме первых, а их там иногда очень много. Я решила эту проблему путем "найти-заменить". Отфильтровала, оставила скобки где мне надо (это городские номера), ну и потом воспользовалась своим макросом. Всё получилось идеально. Я думала, что можно какие-то правки внести в макрос, чтобы это автоматом было, но до сих пор никто не предложил никаких вариантов решения задач, так что немного пришлось вручную сделать.
Все равно спасибо.

Автор - Alina80
Дата добавления - 08.12.2020 в 23:56
CaramelManiac Дата: Среда, 09.12.2020, 08:56 | Сообщение № 6
Группа: Пользователи
Ранг: Участник
Сообщений: 64
Репутация: 22 ±
Замечаний: 0% ±

MS Excel 2003-2019
Здравствуйте.
Ваш макрос ищет телефоны регуляркой, ее и нужно править.
Во вложении вариант, срабатывающий на все российские мобильные номера.
Если нужны и другие номера. Пишите.

PS
У Вас в примере столбы B,C, I,J пустые, но в макросе присутствует обработка ячеек в этих столбах. Если у Вас по 900 тыс. строк в каждом файле, то это получается 3,6 миллиона впустую обработанных ячеек. Оно Вам надо?
К сообщению приложен файл: -v1..xlsm (22.2 Kb)
 
Ответить
СообщениеЗдравствуйте.
Ваш макрос ищет телефоны регуляркой, ее и нужно править.
Во вложении вариант, срабатывающий на все российские мобильные номера.
Если нужны и другие номера. Пишите.

PS
У Вас в примере столбы B,C, I,J пустые, но в макросе присутствует обработка ячеек в этих столбах. Если у Вас по 900 тыс. строк в каждом файле, то это получается 3,6 миллиона впустую обработанных ячеек. Оно Вам надо?

Автор - CaramelManiac
Дата добавления - 09.12.2020 в 08:56
RAN Дата: Среда, 09.12.2020, 12:38 | Сообщение № 7
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
Мявкнем?
[vba]
Код
Function Мяу(Text As String) As String

    Static objRegExp As Object
    Dim objMatches As Object
    Dim s$, ss$, i&
    
    If objRegExp Is Nothing Then
        Set objRegExp = CreateObject("VBScript.RegExp")
        objRegExp.Global = True
    End If

    objRegExp.Pattern = "[^\d,]"
    s = objRegExp.Replace(Text, "")

    objRegExp.Pattern = "(7|8)9\d{9}"
    Set objMatches = objRegExp.Execute(s)

    If objMatches.Count Then
        For i = 1 To objMatches.Count
            s = "+7" & Mid(objMatches(i - 1), 2)
            ss = ss & ", " & s
        Next
        ss = Mid(ss, 3)
    End If

    Мяу = ss
End Function
[/vba]


Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеМявкнем?
[vba]
Код
Function Мяу(Text As String) As String

    Static objRegExp As Object
    Dim objMatches As Object
    Dim s$, ss$, i&
    
    If objRegExp Is Nothing Then
        Set objRegExp = CreateObject("VBScript.RegExp")
        objRegExp.Global = True
    End If

    objRegExp.Pattern = "[^\d,]"
    s = objRegExp.Replace(Text, "")

    objRegExp.Pattern = "(7|8)9\d{9}"
    Set objMatches = objRegExp.Execute(s)

    If objMatches.Count Then
        For i = 1 To objMatches.Count
            s = "+7" & Mid(objMatches(i - 1), 2)
            ss = ss & ", " & s
        Next
        ss = Mid(ss, 3)
    End If

    Мяу = ss
End Function
[/vba]

Автор - RAN
Дата добавления - 09.12.2020 в 12:38
Alina80 Дата: Среда, 09.12.2020, 13:22 | Сообщение № 8
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
CaramelManiac, Добрый день! Ваш вариант макроса идеально подходит под мои данные. Огромное спасибо, что откликнулись.
А что касается столбцов B,C,I,J - то да, действительно раньше там были данные, которые тоже использовались, а теперь эти данные не требуются. И конечно они мне теперь не нужны. Как мне корректно убрать эти столбцы из макроса, будьте добры подскажите?
Очень вам благодарна.)))
 
Ответить
СообщениеCaramelManiac, Добрый день! Ваш вариант макроса идеально подходит под мои данные. Огромное спасибо, что откликнулись.
А что касается столбцов B,C,I,J - то да, действительно раньше там были данные, которые тоже использовались, а теперь эти данные не требуются. И конечно они мне теперь не нужны. Как мне корректно убрать эти столбцы из макроса, будьте добры подскажите?
Очень вам благодарна.)))

Автор - Alina80
Дата добавления - 09.12.2020 в 13:22
Alina80 Дата: Среда, 09.12.2020, 13:52 | Сообщение № 9
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
RAN, И Вам спасибо большое, Ваш вариант тоже подходит.))))
 
Ответить
СообщениеRAN, И Вам спасибо большое, Ваш вариант тоже подходит.))))

Автор - Alina80
Дата добавления - 09.12.2020 в 13:52
CaramelManiac Дата: Среда, 09.12.2020, 16:09 | Сообщение № 10
Группа: Пользователи
Ранг: Участник
Сообщений: 64
Репутация: 22 ±
Замечаний: 0% ±

MS Excel 2003-2019
подскажите

Комментарии во вложенном файле. Надеюсь, подсказал.
К сообщению приложен файл: -v2.xlsm (23.0 Kb)


Сообщение отредактировал CaramelManiac - Среда, 09.12.2020, 16:10
 
Ответить
Сообщение
подскажите

Комментарии во вложенном файле. Надеюсь, подсказал.

Автор - CaramelManiac
Дата добавления - 09.12.2020 в 16:09
Alina80 Дата: Среда, 09.12.2020, 16:23 | Сообщение № 11
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
CaramelManiac, Да, подсказали, в макросе всё подробно расписали, что и как, это как раз для таких тупых как я.))) Спасибо большое. Я только учусь с макросами работать, стараюсь сама разбираться. Но Ваша помощь оказалась очень полезной.
 
Ответить
СообщениеCaramelManiac, Да, подсказали, в макросе всё подробно расписали, что и как, это как раз для таких тупых как я.))) Спасибо большое. Я только учусь с макросами работать, стараюсь сама разбираться. Но Ваша помощь оказалась очень полезной.

Автор - Alina80
Дата добавления - 09.12.2020 в 16:23
Alina80 Дата: Среда, 09.12.2020, 16:24 | Сообщение № 12
Группа: Пользователи
Ранг: Прохожий
Сообщений: 6
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Думаю, что вопрос закрыт! Всем спасибо за помощь и отклики!
 
Ответить
СообщениеДумаю, что вопрос закрыт! Всем спасибо за помощь и отклики!

Автор - Alina80
Дата добавления - 09.12.2020 в 16:24
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Выборка по мобильным номерам телефонов (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!