Option Explicit
Sub Получить_данные()
CloseEmptyWb
Dim aTarget As Variant
aTarget = GetTargetArray(ActiveSheet.UsedRange)
If IsEmpty(aTarget) Then Exit Sub
PrintArray Workbooks.Add(1).Sheets(1).Cells(1, 1), aTarget
End Sub
Private Sub PrintArray(rr As Range, arr As Variant)
With rr.Cells(1 + UBound(arr(1), 1), 1 + UBound(arr(0), 2)).Resize(UBound(arr(2), 1), UBound(arr(2), 2))
.Value = arr(2)
.HorizontalAlignment = xlCenter
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.599963377788629
.PatternTintAndShade = 0
End With
.Cells.FormatConditions.Delete
.Cells.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=0"
.Cells.FormatConditions(.Cells.FormatConditions.Count).SetFirstPriority
With .Cells.FormatConditions(1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With .Cells.FormatConditions(1).Interior
.Pattern = xlNone
.TintAndShade = 0
End With
.Cells.FormatConditions(1).StopIfTrue = False
End With
With rr.Cells(1 + UBound(arr(1), 1), 1).Resize(UBound(arr(0), 1), UBound(arr(0), 2))
.Value = arr(0)
End With
With rr.Cells(1, 1 + UBound(arr(0), 2)).Resize(UBound(arr(1), 1), UBound(arr(1), 2))
.Value = arr(1)
.NumberFormat = "d-mmm"
End With
With rr.Cells(1 + UBound(arr(1), 1), 1 + UBound(arr(0), 2) + UBound(arr(2), 2) + 1).Resize(UBound(arr(3), 1), UBound(arr(3), 2))
.Value = arr(3)
.Rows(0).Value = Array(1, 2)
End With
Set rr = rr.Parent.UsedRange
With rr.Parent.Sort
.SortFields.Clear
.SortFields.Add Key:=rr.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rr
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
rr.Parent.Parent.Saved = True
End Sub
Private Function GetTargetArray(rSource As Range) As Variant
Dim aSource As Variant
aSource = rSource.Value
Dim ys As Long, rSmen As Range, aSmen As Variant
For ys = 1 To UBound(aSource, 1)
If IsDate(aSource(ys, 1)) Then
On Error Resume Next
Set rSmen = rSource.Rows(ys).Find("смена 1")
On Error GoTo 0
If Not rSmen Is Nothing Then
Set rSmen = rSmen.EntireColumn
Set rSmen = Intersect(rSmen, rSource)
aSmen = rSmen.Value
Exit For
End If
End If
Next
If IsEmpty(aSmen) Then Exit Function
For ys = UBound(aSource, 1) To 2 Step -1
If IsEmpty(aSource(ys, 1)) Then
If IsDate(aSource(ys - 1, 1)) Then
aSource(ys, 1) = aSource(ys - 1, 1)
End If
End If
Next
Dim xs As Long, dicFIO As Object, dicDat As Object, dicSmen As Object
Set dicDat = CreateObject("Scripting.Dictionary")
For ys = 1 To UBound(aSource, 1)
If Not IsEmpty(aSource(ys, 1)) Then
If IsDate(aSource(ys, 1)) Then
dicDat(aSource(ys, 1)) = Empty
End If
End If
Next
If dicDat.Count = 0 Then Exit Function
Dim aDates As Variant
aDates = dicDat.Keys()
Set dicFIO = CreateObject("Scripting.Dictionary")
For xs = rSmen.Column + 1 To UBound(aSource, 2)
If aSource(2, xs) = "Сотрудник" Then
For ys = 1 To UBound(aSource, 1)
If Not IsEmpty(aSource(ys, xs)) Then
If aSmen(ys, 1) Like "смена #" Then
If IsDate(aSource(ys, 1)) Then
If dicFIO.Exists(aSource(ys, xs)) Then
Set dicDat = dicFIO(aSource(ys, xs))
Else
Set dicDat = CreateObject("Scripting.Dictionary")
End If
If dicDat.Exists(aSource(ys, 1)) Then
Set dicSmen = dicDat(aSource(ys, 1))
Else
Set dicSmen = CreateObject("Scripting.Dictionary")
End If
dicSmen(aSmen(ys, 1)) = Empty
Set dicDat(aSource(ys, 1)) = dicSmen
Set dicSmen = Nothing
Set dicFIO(aSource(ys, xs)) = dicDat
Set dicDat = Nothing
End If
End If
End If
Next
End If
Next
If dicFIO.Count = 0 Then Exit Function
Dim targFIO As Variant, targSmen As Variant, targDate As Variant, targSum As Variant
ReDim targFIO(1 To dicFIO.Count, 1 To 3)
ReDim targSmen(1 To dicFIO.Count, 1 To UBound(aDates) + 1)
ReDim targDate(1 To 1, 1 To UBound(targSmen, 2))
ReDim targSum(1 To dicFIO.Count, 1 To 2)
Dim yt As Long, xt As Long
For yt = 1 To UBound(targFIO, 1)
targFIO(yt, 1) = dicFIO.Keys()(yt - 1)
targFIO(yt, 2) = " (1)/(2)"
targFIO(yt, 3) = "=COUNTIFS(RC[1]:RC[" & UBound(targSmen, 2) & "],1)+COUNTIFS(RC[1]:RC[" & UBound(targSmen, 2) & "],2)+2*COUNTIFS(RC[1]:RC[" & UBound(targSmen, 2) & "],""1,2"")"
targSum(yt, 1) = "=COUNTIFS(RC[-" & UBound(targSmen, 2) + 1 & "]:RC[-2],1)+COUNTIFS(RC[-" & UBound(targSmen, 2) + 1 & "]:RC[-2],""1,2"")"
targSum(yt, 2) = "=COUNTIFS(RC[-" & UBound(targSmen, 2) + 2 & "]:RC[-3],2)+COUNTIFS(RC[-" & UBound(targSmen, 2) + 3 & "]:RC[-4],""1,2"")"
Next
For xt = 1 To UBound(targDate, 2)
targDate(1, xt) = aDates(xt - 1)
Next
For yt = 1 To UBound(targSmen, 1)
Set dicDat = dicFIO.Items()(yt - 1)
For xt = 1 To UBound(targSmen, 2)
If dicDat.Exists(targDate(1, xt)) Then
Set dicSmen = dicDat(targDate(1, xt))
targSmen(yt, xt) = Replace(Join(dicSmen.Keys(), ","), "смена ", "")
Set dicSmen = Nothing
End If
Next
Set dicDat = Nothing
Next
GetTargetArray = Array(targFIO, targDate, targSmen, targSum)
End Function
Private Sub CloseEmptyWb()
Dim wb As Workbook
For Each wb In Application.Workbooks
If wb.Path = "" Then wb.Close False
Next
End Sub
|
