Копирование строк с условием по ячейкам

[drozd1]

Добрый день.

Подскажите, пожалуйста...
Задача: выбрать сотрудников одного подразделения и скопировать строки по отдельным листам, чтобы листы назывались как подразделения.

Пример

ps если есть такая возможность, то на каждый лист вставить еще шапку, которая находится в области A1:D5

[SaLoKiN]

Написал кусочек, пошел домой =) Вообщем сие творение ищет в столбце "B" уникальные значения начиная с адреса B5.
После чего помещает в массив и потом разносит по листам, по дороге доставляя шапку А1:D5. Код всяко неидеальный,но было интересно поиграться. Если никто не поможет -завтра допишу.

Function UniqueValuesFromArray(ByVal arr, ByVal col As Long) As Variant
    ' перебирает все значения в столбце Col двумерного массива arr
   ' в поисках уникальных значений. Возвращает двумерный вертикальный массив
   ' размерностью N * 1, содержащий уникальные значения из столбца col
   If Not IsArray(arr) Then MsgBox "Это не массив!", vbCritical: Exit Function
    If col > UBound(arr, 2) Then MsgBox "Нет такого столбца в массиве!", vbCritical: Exit Function
    If col < LBound(arr, 2) Then MsgBox "Нет такого столбца в массиве!", vbCritical: Exit Function

    On Error Resume Next: Dim coll As New Collection, txt$
    For i = LBound(arr) To UBound(arr)
        txt$ = Trim(arr(i, col)): coll.Add txt$, txt$
    Next i
    ReDim newarr(1 To coll.Count, 1 To 1)
    For i = 1 To coll.Count: newarr(i, 1) = coll(i): Next i
    UniqueValuesFromArray = newarr
 
End Function
Sub ВыборкаУникальных()
    ' берем диапазон ячеек из первого столбца активного листа
   Dim ПервыйСтолбец As Range: Set ПервыйСтолбец = Range("B6", Range("B" & Rows.Count).End(xlUp))

    ' выбираем из него уникальные значения
   МассивУникальных = UniqueValuesFromArray(ПервыйСтолбец.Value, 1)

 
   
   On Error Resume Next
   ii = UBound(МассивУникальных)
   For i = 1 To ii
Sheets(МассивУникальных(i, 1)).Select
If Err Then
    Err.Clear
    Sheets.Add.Name = МассивУникальных(i, 1)
    Sheets("Лист 1").Range("A1:D5").Copy Range("A1")
    Else
   
End If
   
Next
Sheets("Лист 1").Select
   
End Sub

[SaLoKiN]

Барабанная дробь!!!

Function UniqueValuesFromArray(ByVal arr, ByVal col As Long) As Variant
    ' перебирает все значения в столбце Col двумерного массива arr
   ' в поисках уникальных значений. Возвращает двумерный вертикальный массив
   ' размерностью N * 1, содержащий уникальные значения из столбца col
   If Not IsArray(arr) Then MsgBox "Это не массив!", vbCritical: Exit Function
    If col > UBound(arr, 2) Then MsgBox "Нет такого столбца в массиве!", vbCritical: Exit Function
    If col < LBound(arr, 2) Then MsgBox "Нет такого столбца в массиве!", vbCritical: Exit Function

    On Error Resume Next: Dim coll As New Collection, txt$
    For i = LBound(arr) To UBound(arr)
        txt$ = Trim(arr(i, col)): coll.Add txt$, txt$
    Next i
    ReDim newarr(1 To coll.Count, 1 To 1)
    For i = 1 To coll.Count: newarr(i, 1) = coll(i): Next i
    UniqueValuesFromArray = newarr
 
End Function
Sub ВыборкаУникальных()
    ' берем диапазон ячеек из искомого столбца активного листа
   Dim ИскомыйСтолбец As Range: Set ИскомыйСтолбец = Range("B6", Range("B" & Rows.Count).End(xlUp))

    ' выбираем из него уникальные значения
   МассивУникальных = UniqueValuesFromArray(ИскомыйСтолбец.Value, 1)

    ' и заносим их в другой столбец, начиная с ячейки Е2
 '  Range("E2").Resize(UBound(МассивУникальных)).Value = МассивУникальных
   
   ' в "лист 1"
With Sheets("Лист 1")
' нашли последнюю запись в столбце "B"
iLastRow = .Range("B" & .Rows.Count).End(xlUp).Row
a = .Range(.Cells(6, 1), .Cells(iLastRow, 4)) ' загрузили массив
End With
'


' Создали Листы с нужными разделами.
   On Error Resume Next
   ii = UBound(МассивУникальных)
jj = 1
For i = 1 To ii
    Sheets(МассивУникальных(i, 1)).Select  '  нужно изменить метод поиска листа
    If Err Then                            '  прыгать на каждый лист не прикольно
        Err.Clear
        Sheets.Add.Name = МассивУникальных(i, 1)
    End If
    
    ' докинули шапку
    Sheets("Лист 1").Range("A1:D5").Copy Range("A1")
    
    ' заносим информацию на листы
    For j = 1 To UBound(a, 1)
    'Если элемет массива "а", где 2- это подразделение = уникальному названию подразделения
     If a(j, 2) = МассивУникальных(i, 1) Then
     ' тогда переносим значения на этот лист
   Sheets(МассивУникальных(i, 1)).Cells(jj + 5, 1) = a(j, 1)
   Sheets(МассивУникальных(i, 1)).Cells(jj + 5, 2) = a(j, 2)
   Sheets(МассивУникальных(i, 1)).Cells(jj + 5, 3) = a(j, 3)
   Sheets(МассивУникальных(i, 1)).Cells(jj + 5, 4) = a(j, 4)
   jj = jj + 1
   End If
Next
jj = 1
Next

Sheets("Лист 1").Select ' если метод поиска листа сменить, это нафиг не надо
      
End Sub

[drozd1]

Сообщение от SaLoKiN

Барабанная дробь!!!

Function
...
End Sub

Большое спасибо!!! Все работает! Все гуд!! А подскажите еще как указать тип ячеек в столбце "Начало дня"? (чтобы время там показывало, а не число)

[SaLoKiN]

Добавьте строчку

Sheets(МассивУникальных(i, 1)).Cells(jj + 5, 4).NumberFormat = "[$-F400]h:mm:ss AM/PM"

Где происходит перенос значений на лист

[drozd1]

Сообщение от SaLoKiN

Добавьте строчку

Sheets(МассивУникальных(i, 1)).Cells(jj + 5, 4).NumberFormat = "[$-F400]h:mm:ss AM/PM"

Где происходит перенос значений на лист

Спасибо, огромное!