Необходимо перенести данные из одного столбца в другой.

Страница 1 из 1 1
Модератор форума: китин, _Boroda_, DrMini

Необходимо перенести данные из одного столбца в другой. (Макросы/Sub)

AlenaG

Дата: Вторник, 27.03.2018, 18:23 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 2

Репутация: 0 ±

Замечаний: 20% ±

Excel 2013

Есть таблица, в которой столбцы A-C это исходные данные. И рядом есть столбцы E-G, в которых указаны также данные, но с телефонами. Мне необходимо найти человека из второй части таблицы и проверить, если он есть в первой части, то в столбец C должен попасть его номер телефона.
Я делаю через макрос.
Но ничего не получается. Не пойму где ошибка в макросе.
Пожалуйста, подскажите.
Файл прилагаю.

[vba]

Код

Sub Telefon()
With Worksheets("Лист1")
arr = .Range("E2:G" & .Cells(.Rows.Count, "G").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:C" & .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("B2:C").Resize(UBound(arr), 6) = arr
End With
End Sub

[/vba]

К сообщению приложен файл: 2345.xlsx (11.1 Kb)

Сообщение отредактировал Pelena - Среда, 28.03.2018, 06:32

Ответить

Kuzmich

Дата: Вторник, 27.03.2018, 19:16 | Сообщение № 2

Группа: Проверенные

Ранг: Ветеран

Сообщений: 717

Репутация: 159 ±

Замечаний: 0% ±

Excel 2003

[vba]

Код

Sub Poisk()
Dim i As Long
Dim iLastRow As Long
Dim FoundFIO As Range
iLastRow = Cells(Rows.Count, "E").End(xlUp).Row
  For i = 2 To iLastRow
    Set FoundFIO = Columns("A").Find(Cells(i, "E"), , xlValues, xlWhole)
    If Not FoundFIO Is Nothing Then
      Cells(FoundFIO.Row, "C") = Cells(i, "G")
    End If
  Next
End Sub

[/vba]