Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 04.11.2018, 02:15   #1
А л е н а
 
Регистрация: 28.03.2018
Сообщений: 7
По умолчанию Требуется корректировка в макросе

Есть таблица.Надо найти совпадения из ячеек H,I,J к ячейкам A,B,C. если совпадения найдутся, то моб.тел. из ячейки K должен попасть в ячейку F. К сожалению, макросы плохо знаю, взяла из предыдущих вариантов. Подскажите, что здесь подправить нужно, пожалуйста.
Макрос:
Sub Telefon()
Dim arr(), Dic As Object, i&
With Worksheets("Лист1")
arr = .Range("H2:L" & .Cells(.Rows.Count, "L").End(xlUp).Row).Value
Set Dic = CreateObject("Scripting.Dictionary" )
For i = 1 To UBound(arr)
iKey = UCase(Trim(arr(i, 1)) & Trim(arr(i, 2)) & Trim(arr(i, 3)) & CStr(arr(i, 4)))
If Not Dic.exists(iKey) Then Dic.Add iKey, CStr(arr(i, 5))
Next
arr = .Range("A2:E" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
ReDim Preserve arr(1 To UBound(arr, 1), 1 To 6)
For i = 1 To UBound(arr)
iKey = UCase(Trim(arr(i, 1)) & Trim(arr(i, 2)) & Trim(arr(i, 3)) & CStr(arr(i, 4)))
If Dic.exists(iKey) Then arr(i, 6) = Format(Dic.Item(iKey), "(###)###-##-##")
Next
.[a2].Resize(UBound(arr), 6) = arr
End With
End Sub
Вложения
Тип файла: xlsx 1.xlsx (12.2 Кб, 23 просмотров)

Последний раз редактировалось А л е н а; 04.11.2018 в 02:56.
А л е н а вне форума Ответить с цитированием
Старый 04.11.2018, 10:51   #2
Казанский
Старожил
 
Аватар для Казанский
 
Регистрация: 31.12.2010
Сообщений: 2,133
По умолчанию

Вспомогательный столбец + ВПР не устроит?
В примере нет ни одного совпадения.
Вложения
Тип файла: xlsx 1 (23).xlsx (13.9 Кб, 10 просмотров)
exceleved@yandex.ru Яндекс.Деньги: 410011500007619
Казанский вне форума Ответить с цитированием
Старый 04.11.2018, 12:22   #3
А л е н а
 
Регистрация: 28.03.2018
Сообщений: 7
По умолчанию

Спасибо за ответ. Но у меня база очень большая около 900 000 строк. И с помощью формул не получается, всё висит долго и нет положительного результата. Макрос это идеальный вариант для такого объема, но видимо у меня неверно написан макрос. Поэтому прошу помощи.
А л е н а вне форума Ответить с цитированием
Старый 04.11.2018, 14:33   #4
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,166
По умолчанию

На 900 000 строк сколько Ивановых Иванов Ивановичей? А Петровичей?
Код почти годится, нужно только подправить и повыкидывать лишнее.
Но прежде чем править - нужно бы видеть реальную структуру, чтоб потом опять не править... Вы ведь не собираетесь реально искать совпадения только по ФИО?
Хотя вот скорректировал под указанную задачу, переделывайте сами под реальную:
Код:
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) = Format(Dic.Item(iKey), "(###)###-##-##")
        Next
        
        .[F2].Resize(UBound(arr2), 1) = arr2
    End With
End Sub
webmoney: E265281470651 Z422237915069 R418926282008

Последний раз редактировалось Hugo121; 04.11.2018 в 14:44.
Hugo121 вне форума Ответить с цитированием
Старый 04.11.2018, 14:47   #5
А л е н а
 
Регистрация: 28.03.2018
Сообщений: 7
По умолчанию

Спасибо большое. Буду пробовать.
А л е н а вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
БД корректировка Kolya23 БД в Delphi 1 08.06.2015 17:56
Корректировка кода Benjus Общие вопросы C/C++ 0 08.12.2011 01:07
Корректировка БД nataly_ukr БД в Delphi 5 07.11.2007 15:04