Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Поиск номера телефона по ФИО: ошибка при выполнении макроса
 
#1
12.12.2017 05:26:45
Подскажите, пожалуйста, что я не так меняю в макросе?
Был файл, в котором необходимо было произвести определенные действия с помощью макроса (файл "Предыдущая таблица").
Код
Sub test() 
Dim arr(), i&, itxt 
Dim dic As Object 
Set dic = CreateObject("Scripting.Dictionary") 
With Лист1 
   arr = .Range(.[e2], .[f2].End(xlDown)).Value 
   For i = 1 To UBound(arr) 
       dic.Item(CStr(arr(i, 1))) = arr(i, 2) 
   Next i 
   Erase arr 
   arr = .Range(.[c2], .[a2].End(xlDown)).Value 
   For i = 1 To UBound(arr) 
       itxt = Trim(arr(i, 1)) & " " & Trim(arr(i, 2)) 
       If dic.exists(itxt) Then arr(i, 3) = dic.Item(itxt) 
   Next i 
   .Range("a2").Resize(UBound(arr), UBound(arr, 2)).Value = arr 
End With 
End Sub

В текущей таблице (прилагаю) мне также необходимо найти человека в табличке 1 с ФИО как в табличке 2 и если есть совпадения вставить номер телефона в столбец F. Я пытаюсь изменить макрос под текущую таблицу, но постоянные ошибки явно дают понять, что что-то не так делаю.
Код
Sub test() 
Dim arr(), i&, itxt 
Dim dic As Object 
Set dic = CreateObject("Scripting.Dictionary") 
With Лист1 
   arr = .Range(.[h2], .[i2], .[j2], .[k2], .[l2].End(xlDown)).Value 
   For i = 1 To UBound(arr) 
       dic.Item(CStr(arr(i, 1))) = arr(i, 2) 
   Next i 
   Erase arr 
   arr = .Range(.[f2], .[a2], .[b2], .[c2], .[d2].End(xlDown)).Value 
   For i = 1 To UBound(arr) 
       itxt = Trim(arr(i, 1)) & " " & Trim(arr(i, 2)) 
       If dic.exists(itxt) Then arr(i, 3) = dic.Item(itxt) 
   Next i 
   .Range("a2").Resize(UBound(arr), UBound(arr, 2)).Value = arr 
End With 
End Sub

Заранее благодарю за ответы.
 
 
 
#2
12.12.2017 06:00:45
Для начала:
Код
.Range(.[e2], .[f2].End(xlDown)) - это блок ячеек E2:F14

у Вас
Код
.Range(.[h2], .[i2], .[j2], .[k2], .[l2].End(xlDown))
- это непонятно, что
и т.д.

Хотите сделать всё "с наскоку", не вникая, "чужими руками"? :)
Изменено: Михаил Лебедев - 12.12.2017 15:59:16
Всё сложное - не нужно. Всё нужное - просто /М. Т. Калашников/
 
 
 
#3
12.12.2017 16:09:57
Михаил Лебедев

Я Вас не поняла.
В первом случае в коде нет ошибок и там всё ясно.
Я пытаюсь изменить код под вторую таблицу, а так несколько столбцов. Я ранее всё расписала, что мне необходимо сделать.
Изменено: LenaG - 12.12.2017 17:26:27
 
 
 
#4
12.12.2017 16:55:06
Если несколько столбцов, укажите первый и последний, в этом случае код будет правильный. А у вас синтаксическая ошибка.
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#5
12.12.2017 16:55:33
Код
Sub Telefon()
With Worksheets("Лист1")
    arr = .Range("H2:L" & .Cells(.Rows.Count, "L").End(xlUp).Row).Value
    Set dic = CreateObject("Scripting.Dictionary")
    On Error Resume Next
    For I = 1 To UBound(arr)
        iKey = Trim(arr(I, 1)) & Trim(arr(I, 2)) & Trim(arr(I, 3)) & CStr(arr(I, 4))
        dic.Add iKey, CStr(arr(I, 5))
    Next
    Erase arr
    arr = .Range("A2:F" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
    For I = 1 To UBound(arr)
        iKey = Trim(arr(I, 1)) & Trim(arr(I, 2)) & Trim(arr(I, 3)) & CStr(arr(I, 4))
        If dic.Exists(iKey) Then arr(I, 6) = dic(iKey)
    Next
    .Range("A2").Resize(UBound(arr), 6) = arr
End With
End Sub
Согласие есть продукт при полном непротивлении сторон
 
 
 
#6
12.12.2017 17:09:47
Nordheim, спасибо огромное Вам. Я поняла теперь свою ошибку.
Sanja, Вам громадное спасибо, что помогли разобраться.
Изменено: LenaG - 12.12.2017 17:56:20
 
 
 
Страницы: 1
Наверх