Option Explicit
Private Sub Worksheet_Activate()
Заполнить_смены SourceRange:=Sheets("Смены").Range("A1"), targetRange:=ActiveSheet.Range("область_данных")
End Sub
Sub Заполнить_смены(SourceRange As Range, targetRange As Range)
Set SourceRange = SourceRange.CurrentRegion
Set targetRange = Intersect(targetRange, targetRange.Parent.UsedRange)
Dim dicSmen As Object
Set dicSmen = GetSmenDic(SourceRange)
Dim yName As Object
Set yName = GetNamesYdic(targetRange.Columns(1), dicSmen)
Dim xDate As Object
Set xDate = GetDateXdic(targetRange.Rows(1), dicSmen)
Dim aTarg As Variant
aTarg = InitTargetArray(yName, xDate)
FillTargetArray aTarg, yName, xDate, dicSmen
Set targetRange = targetRange.Cells(LBound(aTarg, 1), LBound(aTarg, 2))
Set targetRange = targetRange.Resize(UBound(aTarg, 1) - LBound(aTarg, 1) + 1)
Set targetRange = targetRange.Resize(, UBound(aTarg, 2) - LBound(aTarg, 2) + 1)
targetRange.Value = aTarg
End Sub
Private Sub FillTargetArray(aTarg As Variant, yName As Object, xDate As Object, dicSmen As Object)
Dim dicName As Object
Dim dd As Variant, xt As Long
Dim nn As Variant, yt As Long
For Each dd In dicSmen.Keys
xt = xDate(dd)
Set dicName = dicSmen(dd)
For Each nn In dicName.Keys
yt = yName(nn)
aTarg(yt, xt) = TranslateTabel(dicName(nn))
Next
Next
End Sub
Private Function TranslateTabel(sSource As String) As String
TranslateTabel = Left(sSource, 1)
End Function
Private Function InitTargetArray(yName As Object, xDate As Object) As Variant
Dim aTarg As Variant, iMin As Long, iMax As Long
Dim vv As Variant
For Each vv In yName.Items
If iMax < vv Then
iMax = vv
End If
If iMin = 0 Then
iMin = vv
ElseIf iMin > vv Then
iMin = vv
End If
Next
ReDim aTarg(iMin To iMax)
iMax = 0
iMin = 0
For Each vv In xDate.Items
If iMax < vv Then
iMax = vv
End If
If iMin = 0 Then
iMin = vv
ElseIf iMin > vv Then
iMin = vv
End If
Next
ReDim aTarg(LBound(aTarg) To UBound(aTarg), iMin To iMax)
InitTargetArray = aTarg
End Function
Private Function GetDateXdic(targetRange As Range, dicSmen As Object) As Object
Dim aDate As Variant
aDate = targetRange.Value
ClearArray aDate
Dim dicDate As Object
Set dicDate = CreateObject("Scripting.Dictionary")
Dim dd As Variant
For Each dd In dicSmen.Keys
dicDate(dd) = 0
Next
Dim xa As Long, xm As Long
For xa = UBound(aDate, 2) To 1 Step -1
If dicDate.Exists(aDate(1, xa)) Then
dicDate(aDate(1, xa)) = xa
End If
Next
xm = UBound(aDate, 2)
For Each dd In dicDate.Keys
If dicDate(dd) = 0 Then
xm = xm + 1
dicDate(dd) = xm
targetRange.Cells(1, xm).Value = dd
End If
Next
Set GetDateXdic = dicDate
End Function
Private Function GetNamesYdic(targetRange As Range, dicSmen As Object) As Object
Dim aName As Variant
aName = targetRange.Value
ClearArray aName
Dim dicName As Object
Set dicName = CreateObject("Scripting.Dictionary")
Dim dd As Variant, nn As Variant
For Each dd In dicSmen.Items
For Each nn In dd.Keys
dicName(nn) = 0
Next
Next
Dim ya As Long, ym As Long
For ya = UBound(aName, 1) To 1 Step -1
If dicName.Exists(aName(ya, 1)) Then
dicName(aName(ya, 1)) = ya
If ym < ya Then ym = ya
End If
Next
For Each nn In dicName.Keys
If dicName(nn) = 0 Then
ym = ym + 1
dicName(nn) = ym
targetRange.Cells(ym, 1).Value = nn
End If
Next
Set GetNamesYdic = dicName
End Function
Private Function GetSmenDic(SourceRange As Range) As Object
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim arr As Variant
arr = SourceRange.Value
ClearArray arr
Dim ya As Long
For ya = 1 To UBound(arr, 1)
If Not IsEmpty(arr(ya, 1)) Then
If IsDate(arr(ya, 1)) Then
If Not dic.Exists(arr(ya, 1)) Then
Set dic(arr(ya, 1)) = CreateObject("Scripting.Dictionary")
End If
End If
End If
Next
Dim xa As Long, xt As Long
For xa = UBound(arr, 2) To 2 Step -1
If arr(1, xa) = "Тип работы" Then
xt = xa
Exit For
End If
Next
If xt = 0 Then xt = UBound(arr, 2)
For xa = 2 To xt - 1
If arr(1, xa) Like "Работник*" Then
For ya = 2 To UBound(arr, 1) 'To 2 Step -1
If dic.Exists(arr(ya, 1)) Then
If Not dic(arr(ya, 1)).Exists(arr(ya, xa)) Then
Set dic(arr(ya, 1))(arr(ya, xa)) = CreateObject("Scripting.Dictionary")
End If
dic(arr(ya, 1))(arr(ya, xa)) = arr(ya, xt)
End If
Next
End If
Next
Set GetSmenDic = dic
End Function
Private Sub ClearArray(arr As Variant)
Dim ya As Long
Dim xa As Long
For ya = LBound(arr, 1) To UBound(arr, 1)
For xa = LBound(arr, 2) To UBound(arr, 2)
If IsError(arr(ya, xa)) Then
arr(ya, xa) = Empty
End If
Next
Next
End Sub
|
