Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос для заполнения таблицы из другой таблицы
 
#1
26.07.2016 13:00:48
Добрый день!

Подскажите, пожалуйста, как можно это реализовать?

Задача
1) скопировать ячейку из столбца A файла "Список" (там находится ФИО)
2) найти скопированное ФИО в файле "БД16" в столбце C (ФИО в файле может повторяться)
3) скопировать ячейки, соответствующие найденному ФИО, из файла "Список" (они выделены цветом) в файл "БД16":
   из столбца J в столбец AR, из M в AU, из C в AW, из D в AX, из E в AY
4) если ФИО в файле "БД16" не найдено, выделить его желтым цветом в файле "Список"
5) повторить тоже самое со следующей ячейкой из столбца A файла "Список"

Что у меня получается сейчас (для модуля листа1 файла "Список", обе книги открыты):
Код
Sub Заполнить()
Application.ScreenUpdating = False
Dim i As Long
Dim iLastRow As Long
Dim Nomer As String
Dim FoundNomer As Range
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
   For i = 2 To iLastRow  'до последнего заполненного поля
     Nomer = Cells(i, 1)
     With Workbooks("БД16.xlsx").Worksheets("База")
       Set FoundNomer = .Columns(A).Find(Nomer, , xlValues, xlWhole)
       If Not FoundNomer Is Nothing Then
          Cells(FoundNomer.Row, 44) = .Cells(i, 10)  'Поступл.дата
          Cells(FoundNomer.Row, 47) = .Cells(i, 13)  'Процент занятости(ставка)
          Cells(FoundNomer.Row, 49) = .Cells(i, 12)  'Город
          Cells(FoundNomer.Row, 50) = .Cells(i, 3)  'Должность
          Cells(FoundNomer.Row, 51) = .Cells(i, 5)  'Группа
       Else
         Cells(i, 1).Interior.Color = 65535
       End If
     End With
   Next
Application.ScreenUpdating = True
End Sub
Изменено: Эстеэрэль - 26.07.2016 13:19:00
 
 
 
#2
26.07.2016 17:56:33
Цитата
как можно это реализовать?
Вы в макросе перепутали откуда и куда копировать данные.
Вам из книги Список надо скопировать данные в книгу БД16 по соответствующим фамилиям.
В книге БД16 фамилии в столбце С, поэтому код переделайте на
Код
       Set FoundNomer = .Columns(3).Find(Nomer, , xlValues, xlWhole)
       If Not FoundNomer Is Nothing Then
          .Cells(FoundNomer.Row, 44) = Cells(i, 10)  'Поступл.дата
          .Cells(FoundNomer.Row, 47) = Cells(i, 13)  'Процент занятости(ставка)
          .Cells(FoundNomer.Row, 49) = Cells(i, 12)  'Город
          .Cells(FoundNomer.Row, 50) = Cells(i, 3)   'Должность
          .Cells(FoundNomer.Row, 51) = Cells(i, 5)   'Группа
Удачи!
 
 
 
#3
26.07.2016 22:12:07
Kuzmich, большое спасибо!
 
 
 
#4
26.07.2016 22:16:46
Еще такой вопрос: возможно ли сделать так, чтобы макрос при повторении ФИО в файле "БД16", вставлял данные во все строки в этим ФИО?
 
 
 
#5
26.07.2016 22:20:28
Цитата
при повторении ФИО в файле "БД16",
Вы хотите, чтобы были полностью дублирующие строки? Зачем?
 
 
 
#6
26.07.2016 22:47:55
В файле "БД16" ячейка с ФИО может повторятся, но результаты в других ячейках этих строк будут разные, поэтому повторяющихся строк не получится.
 
 
 
#7
26.07.2016 23:26:57
Цитата
В файле "БД16" ячейка с ФИО может повторятся
Измените макрос, вставил часть очищения столбца А от предыдущего заполнения ячеек цветом
Код
Sub Заполнить()
Application.ScreenUpdating = False
Dim i As Long
Dim iLastRow As Long
Dim Nomer As String
Dim FoundNomer As Range
Dim FAdr As String
   iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
     Range("A2:A" & iLastRow).Interior.ColorIndex = xlColorIndexNone
   For i = 2 To iLastRow  'до последнего заполненного поля
     Nomer = Cells(i, 1)
     With Workbooks("БД16.xlsx").Worksheets("База")
       Set FoundNomer = .Columns(3).Find(Nomer, , xlValues, xlWhole)
       If Not FoundNomer Is Nothing Then
         FAdr = FoundNomer.Address
         Do
          .Cells(FoundNomer.Row, 44) = Cells(i, 10)  'Поступл.дата
          .Cells(FoundNomer.Row, 47) = Cells(i, 13)  'Процент занятости(ставка)
          .Cells(FoundNomer.Row, 49) = Cells(i, 12)  'Город
          .Cells(FoundNomer.Row, 50) = Cells(i, 3)   'Должность
          .Cells(FoundNomer.Row, 51) = Cells(i, 5)   'Группа
          Set FoundNomer = .Columns(3).FindNext(FoundNomer)
         Loop While FoundNomer.Address <> FAdr
       Else
         Cells(i, 1).Interior.ColorIndex = 6
       End If
     End With
   Next
Application.ScreenUpdating = True
End Sub
Изменено: Kuzmich - 26.07.2016 23:30:28
 
 
 
#8
27.07.2016 10:09:17
Kuzmich, огромное спасибо!
 
 
 
Страницы: 1
Наверх