Добрый вечер! Прошу помощи в сравнении и переносе данных на новый лист. 1. Есть база данных сотрудников столбец В, в котором указаны полностью фамилия, имя и отчество это примерно 2500 человек. Каждому сотруднику присвоен Тном это столбец С. 2. Есть список столбец Е, в котором указаны фамилии и имена полностью, а отчество частично. Необходимо из столбца Е (по фамилии и имени) найти в столбце В и найденное в В скопировать вместе с соответствующим Тном на новый лист (или в любое другое место). 3. И если совпадений в столбце В нет, то данные в столбце Е выделяются. За оперативность буду благодарна.
Добрый вечер! Прошу помощи в сравнении и переносе данных на новый лист. 1. Есть база данных сотрудников столбец В, в котором указаны полностью фамилия, имя и отчество это примерно 2500 человек. Каждому сотруднику присвоен Тном это столбец С. 2. Есть список столбец Е, в котором указаны фамилии и имена полностью, а отчество частично. Необходимо из столбца Е (по фамилии и имени) найти в столбце В и найденное в В скопировать вместе с соответствующим Тном на новый лист (или в любое другое место). 3. И если совпадений в столбце В нет, то данные в столбце Е выделяются. За оперативность буду благодарна.nika
Sub www() Dim arr1, arr2, c, x, ii, y, ss arr1 = Range("B3:C" & Cells(Rows.Count, 2).End(xlUp).Row).Value arr2 = Range("E3:E" & Cells(Rows.Count, 5).End(xlUp).Row).Value
ReDim c(1 To UBound(arr1), 1 To 2)
For x = 1 To UBound(arr2) For y = 1 To UBound(arr1) ss = Len(arr2(x, 1)) If Mid(arr1(y, 1), 1, ss) = arr2(x, 1) Then ii = ii + 1 c(ii, 1) = arr1(y, 1) c(ii, 2) = arr1(y, 2) End If Next Next
With Sheets(2) .[B1].Resize(UBound(c), 2) = c .Activate End With End Sub
[/vba]
[vba]
Code
Sub www() Dim arr1, arr2, c, x, ii, y, ss arr1 = Range("B3:C" & Cells(Rows.Count, 2).End(xlUp).Row).Value arr2 = Range("E3:E" & Cells(Rows.Count, 5).End(xlUp).Row).Value
ReDim c(1 To UBound(arr1), 1 To 2)
For x = 1 To UBound(arr2) For y = 1 To UBound(arr1) ss = Len(arr2(x, 1)) If Mid(arr1(y, 1), 1, ss) = arr2(x, 1) Then ii = ii + 1 c(ii, 1) = arr1(y, 1) c(ii, 2) = arr1(y, 2) End If Next Next
With Sheets(2) .[B1].Resize(UBound(c), 2) = c .Activate End With End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
