Страницы: 1
RSS
Подстановка Фамилии по должности из списка
 
Добрый день!
Подскажите пожалуйста, как заполнить таблицу Фамилиями с привязкой к должностям, имея исходные данные и список должностей, к которым нужно подтянуть соответствующие должности.
Заранее спасибо.
Изменено: Alex_paw - 20.06.2017 15:01:52
 
Фамилии напротив должности в одной ячейке через ","?
"Все гениальное просто, а все простое гениально!!!"
 
Не совсем понял вопрос, извините.
 
Через пользовательскую функцию написал
 
В данном файле список должностей как бы и не нужен, к тому же он не полный.
Код
Sub Familia()
Dim dicObj As Object
Dim i&, arr$()
Set dicObj = CreateObject("Scripting.Dictionary")
'With Sheets("Список ДОЛЖНОСТЕЙ")
'    For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
'        dicObj.Item(CStr(Cells(i, 1))) = ""
'    Next i
'End With
With Sheets("Данные")
    For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
'        arr = Split(.Cells(i, 2), " ")
'        dicObj.Item(CStr(.Cells(i, 1))) = dicObj.Item(CStr(.Cells(i, 1))) & arr(0) & ","
        dicObj.Item(CStr(.Cells(i, 1))) = dicObj.Item(CStr(.Cells(i, 1))) & .Cells(i, 2) & ","
    Next i
End With
With Sheets("СВОД")
'    For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
'        Cells(i, 2) = dicObj.Item(CStr(.Cells(i, 1)))
'        arr = Split(dicObj.Item(CStr(.Cells(i, 1))), ",")
'        Cells(i, 2).Resize(, UBound(arr)) = arr
'    Next i
    .Cells(2, 1).Resize(dicObj.Count) = Application.Transpose(dicObj.Keys)
    .Cells(2, 2).Resize(dicObj.Count) = Application.Transpose(dicObj.Items)
End With
End Sub
Изменено: Nordheim - 19.06.2017 17:09:23
"Все гениальное просто, а все простое гениально!!!"
 
Цитата
Alex_paw написал: Не совсем понял вопрос
каким должен быть список в итоге?
 
Цитата
CrazyRabbit написал:
Через пользовательскую функцию написал
Спасибо большое, но это не совсем то.
Суть как раз и состоит в том, что задействуется не весь перечень должностей, а только тот, что указан в "Список должностей", а вывод данных нужен в таком разрезе:
Должность - ФИО, в столбце должность - весь перечень повторяющихся из списка ("Список Должностей") должностей, а в следующем столбце - ФИО. Т.Е. Если в Данных Директор - 1 должность, то и должность и ФИО займут одну строку, если же продавцов - 10 ,то должно быть и 10 строк с должностью и уникальной ФИО.
.....Как то так......
Тем не менее всем спасибо, что откликнулись......
 
=ЕСЛИОШИБКА(ИНДЕКС(Данные!A$1:A$60;АГРЕГАТ(15;6;СТРОКА($1:$200)/((Данные!$A$1:$A$60='Список ДОЛЖНОСТЕЙ'!$A$2)+(Данные!$A$1:$A$60='Список ДОЛЖНОСТЕЙ'!$A$3)+(Данные!$A$1:$A$60='Список ДОЛЖНОСТЕЙ'!$A$4)+(Данные!$A$1:$A$60='Список ДОЛЖНОСТЕЙ'!$A$5)+(Данные!$A$1:$A$60='Список ДОЛЖНОСТЕЙ'!$A$6)+(Данные!$A$1:$A$60='Список ДОЛЖНОСТЕЙ'!$A$7)+(Данные!$A$1:$A$60='Список ДОЛЖНОСТЕЙ'!$A$8)+(Данные!$A$1:$A$60='Список ДОЛЖНОСТЕЙ'!$A$9)+(Данные!$A$1:$A$60='Список ДОЛЖНОСТЕЙ'!$A$10)+(Данные!$A$1:$A$60='Список ДОЛЖНОСТЕЙ'!$A$11)+(Данные!$A$1:$A$60='Список ДОЛЖНОСТЕЙ'!$A$12));ЧСТРОК($1:1)));"")
Изменено: copper-top - 19.06.2017 18:54:35
 
Макрос в стандартный модуль, запускать при активном листе Список ДОЛЖНОСТЕЙ
Код
Sub Jobtitle_FIO()
Dim i As Long
Dim iLastRow As Long
Dim iLR As Long
Dim Swod As Worksheet
Dim Jobtitle As Range
Dim FAdr As String
 iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Set Swod = Worksheets("СВОД")
   iLR = Swod.Cells(Swod.Rows.Count, "A").End(xlUp).Row + 1
   Swod.Range("A2:B" & iLR).ClearContents
With Worksheets("Данные")
  For i = 2 To iLastRow
     Set Jobtitle = .Columns(1).Find(Cells(i, "A"), , xlValues, xlWhole)
        If Not Jobtitle Is Nothing Then
           FAdr = Jobtitle.Address
           Do
             iLR = Swod.Cells(Swod.Rows.Count, "A").End(xlUp).Row + 1
             Swod.Cells(iLR, "A") = .Cells(Jobtitle.Row, "A")
             Swod.Cells(iLR, "B") = .Cells(Jobtitle.Row, "B")
              Set Jobtitle = .Columns(1).FindNext(Jobtitle)
           Loop While Jobtitle.Address <> FAdr
        End If
  Next
End With
End Sub
 
Спасибо большое. Правда я не очень силён в макросах, но попробую разобраться!
 
Alex_paw, а формула подойдет?
 
Цитата
Kuzmich написал: Макрос в стандартный модуль
Выдаёт ошибку
 
Цитата
Alex_paw написал: Подскажите пожалуйста, как заполнить
Расширенный фильтр, только уникальные. Вызываем с листа СВОД. Как вариант, однако... ;)
Изменено: Z - 20.06.2017 11:59:25
"Ctrl+S" - достойное завершение ваших гениальных мыслей!.. ;)
 
Цитата
Alex_paw написал:
Выдаёт ошибку
Проверил макрос Кузьмича - НИКАКОЙ ошибки нет, список формируется.
 
Честно признаюсь, что с макросами могу (вероятнее всего) тупить, так что наверняка мой косяк. Как выяснить где косячу?
 
Знаки "?" поменяйте на имя первого листа по моему "СВОД", а во втором случае поменяйте  "?" на имя листа "Данные".  
При вставке макроса копированного с сайта в модуль, VBA не воспринимает буквы кириллицы!
Изменено: Nordheim - 20.06.2017 14:12:32
"Все гениальное просто, а все простое гениально!!!"
 
Цитата
Nordheim написал:
При вставке макроса копированного с сайта в модуль, VBA не воспринимает буквы кириллицы!
Воспринимает. Просто копировать нужно при русской раскладке клавиатуры.
 
Юрий М, Пробовал, при любой раскладке выдает белиберду. Причем и дома и на работе!
Изменено: Nordheim - 20.06.2017 15:01:55
"Все гениальное просто, а все простое гениально!!!"
 
Я тоже пробовал и не один раз. И прямо из этой темы скопировал: при RU всё нормально.
 
Цитата
Юрий М написал:
Воспринимает. Просто копировать нужно при русской раскладке клавиатуры.
УРааааааа! Заработало!
Большое спасибо!!!!!
Страницы: 1
Наверх