'v4
Sub FillTiming()
Dim arr As Variant
arr = GetArrTiming(Sheets("Табель").Cells(1, 2).Value) 'Получаем массив для вывода
If IsEmpty(arr) Then Exit Sub 'Если массива нет, выходим из макроса
Dim yy As Long
Dim brr As Variant
With Sheets("Тайминг").Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) 'Диапазон на листе Табель
.Value = arr 'Выводим массив
SortRange .Cells, 2 'Сортируем
.Columns(2).RemoveDuplicates Columns:=1, Header:=xlNo
yy = .Cells(.Rows.Count, 2).End(xlUp).Row
If yy = 1 Then yy = 2
brr = .Cells(1, 2).Resize(yy)
.ClearContents
End With
With Sheets("Тайминг").Cells(2, 1).Resize(UBound(arr, 1), UBound(arr, 2)) 'Диапазон на листе Табель
.Value = arr 'Выводим массив
SortRange .Cells, 1 'Сортируем
.Columns(1).RemoveDuplicates Columns:=1, Header:=xlNo
.Columns(2).ClearContents
End With
With Sheets("Тайминг")
.Cells(1, 2).Resize(1, UBound(brr, 1)) = Application.Transpose(brr)
End With
End Sub
Sub FillTabel()
Dim arr As Variant
arr = GetArrTabel(Sheets("Табель").Cells(1, 2).Value) 'Получаем массив для вывода
If IsEmpty(arr) Then Exit Sub 'Если массива нет, выходим из макроса
With Sheets("Табель").Cells(4, 1).Resize(UBound(arr, 1), UBound(arr, 2)) 'Диапазон на листе Табель
.Value = arr 'Выводим массив
SortRange .Cells, 2 'Сортируем
FillNumber .Columns(1) 'Заполняем номер, первый столбец.
End With
End Sub
Private Function GetArrTabel(monthTabel As Byte)
'Функция, формирующая массив табеля
Dim tb As ListObject
Set tb = Sheets("Для заполнения").ListObjects("Заполнение") 'Получаем умную таблицу на листе Для заполнения
'Запоминаем в массивы столбцы умной таблицы
Dim fio As Variant
Dim dlj As Variant
Dim cat As Variant
Dim nom As Variant
Dim dat As Variant
With tb
fio = .ListColumns("ФИО").Range
dlj = .ListColumns("Должность").Range
cat = .ListColumns("Категория персонала").Range
nom = .ListColumns("Табельный номер").Range
dat = .ListColumns("Дата").Range
End With
'Ключ для словаря для удаления дубликатов
Dim sKey As String
'Промежуточный массив с количеством строк, равным количеству строк в умной таблице
Dim arr As Variant
ReDim arr(1 To UBound(fio, 1), 1 To 5)
'Cловарь для удаления дубликатов
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim flag As Boolean
Dim yy As Long
Dim uu As Long
For yy = 2 To UBound(fio, 1)
flag = False
If IsDate(dat(yy, 1)) Then
If Month(dat(yy, 1)) = monthTabel Then
flag = True
End If
End If
If flag Then
'Ключ для удаления дубликатов. Учитываемые столбцы можно менять.
sKey = Join(Array(nom(yy, 1), fio(yy, 1)), vbTab)
If dic.Exists(sKey) Then flag = False
End If
If flag Then 'Если ключа ещё нет
dic.Item(sKey) = 0 'Добавляем ключ в словарь
uu = uu + 1 'Номер строки. Отличается от y на дубликаты.
arr(uu, 1) = uu
arr(uu, 2) = fio(yy, 1) 'ФИО
arr(uu, 3) = dlj(yy, 1) 'Должность
arr(uu, 4) = cat(yy, 1) 'Категория
arr(uu, 5) = nom(yy, 1) 'Табельный номер
End If
Next
If uu > 0 Then 'Если в промежуточном массиве что-то есть
'Массив для вывода. Тот же массив, что и промежуточный, только без пустых строк.
Dim brr As Variant
ReDim brr(1 To uu, 1 To UBound(arr, 2))
For yy = 1 To UBound(brr, 1)
For uu = 1 To UBound(brr, 2)
brr(yy, uu) = arr(yy, uu)
Next
Next
GetArrTabel = brr
End If
End Function
Private Function GetArrTiming(monthTabel As Byte) As Variant
'Функция, формирующая массив табеля
Dim tb As ListObject
Set tb = Sheets("Для заполнения").ListObjects("Заполнение") 'Получаем умную таблицу на листе Для заполнения
'Запоминаем в массивы столбцы умной таблицы
Dim fio As Variant
Dim dlj As Variant
Dim cat As Variant
Dim nom As Variant
Dim dat As Variant
Dim obj As Variant
With tb
fio = .ListColumns("ФИО").Range
dlj = .ListColumns("Должность").Range
cat = .ListColumns("Категория персонала").Range
nom = .ListColumns("Табельный номер").Range
dat = .ListColumns("Дата").Range
obj = .ListColumns("Объект").Range
End With
'Ключ для словаря для удаления дубликатов
Dim sKey As String
'Промежуточный массив с количеством строк, равным количеству строк в умной таблице
Dim arr As Variant
ReDim arr(1 To UBound(fio, 1), 1 To 2)
'Cловарь для удаления дубликатов
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim flag As Boolean
Dim yy As Long
Dim uu As Long
For yy = 2 To UBound(fio, 1)
flag = False
If IsDate(dat(yy, 1)) Then
If Month(dat(yy, 1)) = monthTabel Then
flag = True
End If
End If
If flag Then
'Ключ для удаления дубликатов. Учитываемые столбцы можно менять.
sKey = Join(Array(nom(yy, 1), fio(yy, 1)), vbTab)
If dic.Exists(sKey) Then flag = False
End If
If flag Then 'Если ключа ещё нет
'dic.Item(sKey) = 0 'Добавляем ключ в словарь
uu = uu + 1 'Номер строки. Отличается от y на дубликаты.
arr(uu, 1) = fio(yy, 1) 'ФИО
arr(uu, 2) = obj(yy, 1)
End If
Next
If uu > 0 Then 'Если в промежуточном массиве что-то есть
'Массив для вывода. Тот же массив, что и промежуточный, только без пустых строк.
Dim brr As Variant
ReDim brr(1 To uu, 1 To UBound(arr, 2))
For yy = 1 To UBound(brr, 1)
For uu = 1 To UBound(brr, 2)
brr(yy, uu) = arr(yy, uu)
Next
Next
GetArrTiming = brr
End If
End Function
Private Sub SortRange(rr As Range, xSort As Long)
'Процедура, сортирующая диапазон
With rr.Parent.Sort
.SortFields.Clear
.SortFields.Add Key:=rr.Columns(xSort), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rr: .Header = xlGuess: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin
.Apply
End With
End Sub
Private Sub FillNumber(rr As Range)
'Заполнение номера, не табельного.
If rr.Rows.Count = 1 Then
rr.Cells(1, 1).Value = 1
Else
Dim arr As Variant
arr = rr.Columns(1).Value
Dim yy As Long
For yy = 1 To UBound(arr, 1)
arr(yy, 1) = yy
Next
rr.Columns(1).Value = arr
End If
End Sub
|
