Страницы: 1
RSS
Заполнение файла с помощью данных из других книг Excel
 
Всем добрый день!

Очень нужна помощь, есть три файла:
Список сотрудников - актуальные данные, кто работает на данный момент;
KPI - информация о том, какие KPI были присвоены каждому сотруднику (при этом сотрудников, которые недавно пришли в компанию здесь нет);
Лист оценки - необходимо этот файл заполнить данными из двух предыдущих:

1 этап - заполнить "шапку" листа оценки (информация о сотруднике и руководителе).
Нашла вариант заполнения данных по сотруднику и руководителю с помощью функции ВПР, при этом нужно в списке сотрудников постоянно менять метку "х", чтобы автоматически подтягивались новые данные. В примере привела меньше 20 человек, а по факту их 5000, я так целый день буду метки ставить. Есть ли вариант автоматического создания именных файлов согласно списка? В идеале мне нужно 5000 файлов, чтобы имя файла было ФИО сотрудника, и в файле уже подтянутые данные.

2 этап - заполнить саму таблицу KPI. Формулой ВПР не получается сделать, т.к. количество показателей KPI разное у сотрудников. Пробовала через Power Query, но я в этом полный ноль. Загрузила таблицу, а как указать условие, что мне  нужно KPI только конкретного сотрудника вывести и куда вывести не знаю((
 
Arina Shichko, Вы бы показали желаемый результат одного из нужных файлов....
ваши этапы у вас в голове - поэтому одна тема один вопрос...первый этап
откуда берутся данные по руководителю?...

первый этап макрос ниже, открываете ваши 2 книги из примера приложенного вами (KPI и Список сотрудников) и затем открываете книгу которую я приложил ( это ваше же файл, но с макросом и другим расширением файла).
файлы сохраняются в ту папку где лежит файл Лист  оценки.xlsm c созданием папки.
Вопрос про руководителя открыт поэтому там подставляется что то левое)
Часть макроса состоит из макроса расположенного ТУТ
Код
Sub pattern()
Dim SPISOK As Workbook, LO As Workbook, KPI As Workbook
Dim lr As Long, i As Long
Set SPISOK = Workbooks("Список сотрудников.xlsx")
Set KPI = Workbooks("KPI.xlsx")
Set LO = Workbooks("Лист оценки.xlsm")
lr = SPISOK.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
LO.Worksheets(1).Cells(3, 3) = SPISOK.Worksheets(1).Cells(i, 3) 'ФИО
LO.Worksheets(1).Cells(4, 3) = SPISOK.Worksheets(1).Cells(i, 4) 'табельный номер
LO.Worksheets(1).Cells(5, 3) = SPISOK.Worksheets(1).Cells(i, 2) 'Должность
LO.Worksheets(1).Cells(6, 3) = SPISOK.Worksheets(1).Cells(i, 1) 'Отдел

LO.Worksheets(1).Cells(3, 5) = SPISOK.Worksheets(1).Cells(i, 1) 'Руководитель
LO.Worksheets(1).Cells(4, 5) = SPISOK.Worksheets(1).Cells(i, 1) 'Должность
LO.Worksheets(1).Cells(5, 5) = SPISOK.Worksheets(1).Cells(i, 1) 'Отдел

On Error Resume Next
    ' название подпапки, в которую по-умолчанию будет предложено сохранить файл
    Const REPORTS_FOLDER = "Листы оценки\"
    ' создаём папку для файла, если её ещё нет
    MkDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
    ' выбираем стартовую папку
    ChDrive Left(ThisWorkbook.Path, 1): ChDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
 
    ' вывод диалогового окна для запроса имени сохраняемого файла
    Filename = LO.Worksheets(1).Cells(3, 3) & "Таб.№" & LO.Worksheets(1).Cells(4, 3) & ".xls"
    ' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
    If VarType(Filename) = vbBoolean Then Exit Sub
 
    ' копируем активный лист (при этом создаётся новая книга)
    Err.Clear: ActiveSheet.Copy: DoEvents
    If Err Then Exit Sub    ' произошла какая-то ошибка при попытке копирования листа

    ' убеждаемся, что активной книгой является копия листа
    If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
        ' сохраняем файл под заданным именем в формате Excel 2003
        ActiveWorkbook.SaveAs Filename, xlWorkbookNormal
 
        ' закрываем сохранённый файл
        ' (удалите следующую строку, если закрывать созданный файл не требуется)
        ActiveWorkbook.Close False
    End If
Next i
End Sub
Изменено: Mershik - 20.09.2020 16:24:33
Не бойтесь совершенства. Вам его не достичь.
 
Цитата
Mershik написал:
Arina Shichko , Вы бы показали желаемый результат одного из нужных файлов....ваши этапы у вас в голове - поэтому одна тема один вопрос...первый этапоткуда берутся данные по руководителю?...

Изменено: Mershik  - 20 сен 2020 15:53:43
Пример готового файла во вложении.

Данные по сотруднику подтянула через ВПР из файла "Список сотрудников"/Лист "Список сотрудников"
Данные по руководителю так же через ВПР из файла "Список сотрудников"/Лист "Руководитель" (данные подтягиваются в зависимости от того, в каком отделе работает сотрудник).

Соответственно, если в файле Список сотрудников проставить метку "х" напротив, например, Гриненко, подтянутся все данные по нему, но мне хотелось бы не метки проставлять, а автоматически создать файлы, похожие на вложенный, по каждому сотруднику.... если это, конечно, возможно
Изменено: Arina Sh - 20.09.2020 16:34:12
 
Цитата
Arina Sh написал:
Данные по руководителю так же через ВПР из файла "Список сотрудников"/Лист "Руководитель" (данные подтягиваются в зависимости от того, в каком отделе работает сотрудник).
вы смотрите что прикладываете в качестве примера? видимо нет - нет там никакого листа кроме "Список сотрудников"
Не бойтесь совершенства. Вам его не достичь.
 
исправила ссылку
Изменено: Arina Sh - 20.09.2020 16:42:01
 
Arina Sh, Ну вы сначала макросом проверьте или вы его в упор не видите?
для последнего примера...
запускаете файлы из архива ставите любой символ напротив фио для которого необходимо создать лист оценки и нажимаете кнопку.
Код
Sub pattern()
Dim SPISOK As Workbook, LO As Workbook, KPI As Workbook
Dim lr As Long, i As Long, Cell As Range, Cell2 As Range
Application.ScreenUpdating = False
Set SPISOK = Workbooks("Список сотрудников.xlsx")
Set KPI = Workbooks("KPI.xlsx")
Set LO = Workbooks("Лист оценки.xlsm")
lr = SPISOK.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row
For i = 2 To lr
LO.Worksheets(1).Range("A9:G15").ClearContents
If SPISOK.Worksheets(1).Cells(i, 1) <> "" Then
LO.Worksheets(1).Cells(3, 3) = SPISOK.Worksheets(1).Cells(i, 4) 'ФИО
LO.Worksheets(1).Cells(4, 3) = SPISOK.Worksheets(1).Cells(i, 5) 'табельный номер
LO.Worksheets(1).Cells(5, 3) = SPISOK.Worksheets(1).Cells(i, 3) 'Должность
LO.Worksheets(1).Cells(6, 3) = SPISOK.Worksheets(1).Cells(i, 2) 'Отдел

Set Cell = SPISOK.Worksheets(2).Columns(1).Find(LO.Worksheets(1).Cells(6, 3))
LO.Worksheets(1).Cells(3, 5) = SPISOK.Worksheets(2).Cells(Cell.Row, 3) 'Руководитель
LO.Worksheets(1).Cells(4, 5) = SPISOK.Worksheets(2).Cells(Cell.Row, 2) 'Должность
LO.Worksheets(1).Cells(5, 5) = SPISOK.Worksheets(2).Cells(Cell.Row, 1) 'Отдел

Set Cell2 = KPI.Worksheets(1).Columns(3).Find(SPISOK.Worksheets(1).Cells(i, 4))
x = Application.WorksheetFunction.CountIf(KPI.Worksheets(1).Columns(3), SPISOK.Worksheets(1).Cells(i, 4))

For k = 0 To x - 1
LO.Worksheets(1).Cells(9 + k, 1) = k + 1
LO.Worksheets(1).Cells(9 + k, 2) = KPI.Worksheets(1).Cells(Cell2.Row + k, 4)
LO.Worksheets(1).Cells(9 + k, 5) = KPI.Worksheets(1).Cells(Cell2.Row + k, 5)
Next k
LO.Worksheets(1).Cells(9 + k, 2) = "ИТОГ"
LO.Worksheets(1).Cells(9 + k, 5) = Application.WorksheetFunction.Sum(Range(Cells(9, 5), Cells(9 + k, 5)))

On Error Resume Next
    ' название подпапки, в которую по-умолчанию будет предложено сохранить файл
    Const REPORTS_FOLDER = "Листы оценки\"
    ' создаём папку для файла, если её ещё нет
    MkDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
    ' выбираем стартовую папку
    ChDrive Left(ThisWorkbook.Path, 1): ChDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
 
    ' вывод диалогового окна для запроса имени сохраняемого файла
    Filename = LO.Worksheets(1).Cells(3, 3) & "Таб.№" & LO.Worksheets(1).Cells(4, 3) & ".xls"
    ' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
    If VarType(Filename) = vbBoolean Then Exit Sub
 
    ' копируем активный лист (при этом создаётся новая книга)
    Err.Clear: ActiveSheet.Copy: DoEvents
    If Err Then Exit Sub    ' произошла какая-то ошибка при попытке копирования листа

    ' убеждаемся, что активной книгой является копия листа
    If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
        ' сохраняем файл под заданным именем в формате Excel 2003
        ActiveWorkbook.SaveAs Filename, xlWorkbookNormal
 
        ' закрываем сохранённый файл
        ' (удалите следующую строку, если закрывать созданный файл не требуется)
        ActiveWorkbook.Close False
    End If
End If
Next i
Application.ScreenUpdating = True
End Sub
Изменено: Mershik - 20.09.2020 17:36:52
Не бойтесь совершенства. Вам его не достичь.
Страницы: 1
Наверх