Добрый день! Подскажите пожалуйста, как заполнить таблицу Фамилиями с привязкой к должностям, имея исходные данные и список должностей, к которым нужно подтянуть соответствующие должности. Заранее спасибо.
В данном файле список должностей как бы и не нужен, к тому же он не полный.
Код
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
CrazyRabbit написал: Через пользовательскую функцию написал
Спасибо большое, но это не совсем то. Суть как раз и состоит в том, что задействуется не весь перечень должностей, а только тот, что указан в "Список должностей", а вывод данных нужен в таком разрезе: Должность - ФИО, в столбце должность - весь перечень повторяющихся из списка ("Список Должностей") должностей, а в следующем столбце - ФИО. Т.Е. Если в Данных Директор - 1 должность, то и должность и ФИО займут одну строку, если же продавцов - 10 ,то должно быть и 10 строк с должностью и уникальной ФИО. .....Как то так...... Тем не менее всем спасибо, что откликнулись......
Макрос в стандартный модуль, запускать при активном листе Список ДОЛЖНОСТЕЙ
Код
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
Знаки "?" поменяйте на имя первого листа по моему "СВОД", а во втором случае поменяйте "?" на имя листа "Данные". При вставке макроса копированного с сайта в модуль, VBA не воспринимает буквы кириллицы!