Option Explicit

Sub test()
    Dim rr As Range
    For Each rr In Intersect(Columns("K:U"), ActiveSheet.UsedRange).Rows
        If rr.Row > 4 Then
            SetFormatConditions rr
        End If
    Next
End Sub
 
Private Sub SetFormatConditions(rr As Range)
    rr.FormatConditions.Delete
    rr.FormatConditions.AddColorScale ColorScaleType:=3
    rr.FormatConditions(rr.FormatConditions.Count).SetFirstPriority
    rr.FormatConditions(1).ColorScaleCriteria(1).Type = xlConditionValueLowestValue
    With rr.FormatConditions(1).ColorScaleCriteria(1).FormatColor
        .Color = 7039480
        .TintAndShade = 0
    End With
    rr.FormatConditions(1).ColorScaleCriteria(2).Type = xlConditionValuePercentile
    rr.FormatConditions(1).ColorScaleCriteria(2).Value = 50
    With rr.FormatConditions(1).ColorScaleCriteria(2).FormatColor
        .Color = 8711167
        .TintAndShade = 0
    End With
    rr.FormatConditions(1).ColorScaleCriteria(3).Type = xlConditionValueHighestValue
    With rr.FormatConditions(1).ColorScaleCriteria(3).FormatColor
        .Color = 8109667
        .TintAndShade = 0
    End With
End Sub

Option Explicit

Sub test()
    Const myRANGE = "A1:J10"

    Dim rr As Range
    For Each rr In Range(myRANGE).Rows
        SetFormatConditions rr
    Next
End Sub

Private Sub SetFormatConditions(rr As Range)
    rr.FormatConditions.Delete
    rr.FormatConditions.AddColorScale ColorScaleType:=3
    rr.FormatConditions(rr.FormatConditions.Count).SetFirstPriority
    rr.FormatConditions(1).ColorScaleCriteria(1).Type = xlConditionValueLowestValue
    With rr.FormatConditions(1).ColorScaleCriteria(1).FormatColor
        .Color = 7039480
        .TintAndShade = 0
    End With
    rr.FormatConditions(1).ColorScaleCriteria(2).Type = xlConditionValuePercentile
    rr.FormatConditions(1).ColorScaleCriteria(2).Value = 50
    With rr.FormatConditions(1).ColorScaleCriteria(2).FormatColor
        .Color = 8711167
        .TintAndShade = 0
    End With
    rr.FormatConditions(1).ColorScaleCriteria(3).Type = xlConditionValueHighestValue
    With rr.FormatConditions(1).ColorScaleCriteria(3).FormatColor
        .Color = 8109667
        .TintAndShade = 0
    End With
End Sub

=ЕСЛИ(СУММ(СМЕЩ(Formula!D5;ДЕНЬНЕД(СЕГОДНЯ();2)-1;0)*J7)=0;"";СУММ(СМЕЩ(Formula!D5;ДЕНЬНЕД(СЕГОДНЯ();2)-1;0)*J7))

Sub AddRecordset()
Dim iRng As Range
Dim iCl As Range
Dim lRow&, J&
On Error Resume Next
Application.ScreenUpdating = False
Set iRng = Worksheets("Лист1").Range("D5,F5,H5,J5,L5,N5,D9,F9,H9,J9")
With Worksheets("Лист5")
  lRow = .Cells(.Rows.Count, "B").End(xlUp).Row 'Тут менять столбец необязательно. Если изначальный столбец F всегда заполнен.
  lRow = IIf(lRow < 3, 3, lRow + 1)
  J = 2                                         'Основная магия тут.
  For Each iCl In iRng.Cells
    .Cells(lRow, J) = iCl.Value
    J = J + 1
  Next
End With
iRng.ClearContents
Application.ScreenUpdating = True
End Sub

=СМЕЩ(C1;ПОИСКПОЗ(B21;СМЕЩ($B$2:$B$13;0;ПОИСКПОЗ(B20;C1:G1;0));0);ПОИСКПОЗ(B20;C1:G1;0))

=СУММ((A2:A13=B17)*(B2:B13=B16)*(C2:C13=B21)*D2:D13)

=СУММ((A2:A13=B17)*(B2:B13=B16)*(C2:G13=B21)*D2:H13)

=СУММ((A2:A13=B17)*(B2:B13=B16)*(C2:G13=B21)*D2:H13)

Sub test111()
Dim a As String, b As Boolean, c As Date
a = FileDateTime("C:\Windows\notepad.exe")

If Len(a) = 0 Then Exit Sub
Dim ya As Long, yb As Long, ch As String
Dim arr As Variant
ReDim arr(1 To Len(a))
For ya = 1 To UBound(arr)
    ch = Mid(a, ya, 1)
    If IsNumeric(ch) Or ch = " " Or ch = ":" Or ch = "." Then
        yb = yb + 1
        arr(yb) = ch
    End If
Next
a = Join(arr, "")
a = Trim(a)

Debug.Print a
b = IsDate(a)
c = DateValue(a)
End Sub

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

Sub test111()
Dim a As String, b As Boolean, c As Date
a = FileDateTime("C:\Windows\notepad.exe")

Dim arr As Variant
arr = Split(a, " ")
a = arr(UBound(arr) - 1) & " " & arr(UBound(arr))
arr = Empty

Debug.Print a
b = IsDate(a)
c = DateValue(a)
End Sub

Sub test111()
Dim a As String, b As Boolean, c As Date
a = FileDateTime("C:\Windows\notepad.exe")
Debug.Print a
b = IsDate(a)
c = DateValue(a)
End Sub

=СЧЁТЕСЛИМН(A:A;A:A;B:B;B:B)
=СЧЁТЕСЛИМН(A:A;A:A;C:C;C:C)
=СЧЁТЕСЛИМН(A:A;A:A;D:D;D:D)
=СЧЁТЕСЛИМН(A:A;A:A;E:E;E:E)
=СЧЁТЕСЛИМН(A:A;A:A;F:F;F:F)
=СЧЁТЕСЛИМН(A:A;A:A;G:G;G:G)
=СЧЁТЕСЛИМН(B:B;B:B;C:C;C:C)
=СЧЁТЕСЛИМН(B:B;B:B;D:D;D:D)
=СЧЁТЕСЛИМН(B:B;B:B;E:E;E:E)
=СЧЁТЕСЛИМН(B:B;B:B;F:F;F:F)
=СЧЁТЕСЛИМН(B:B;B:B;G:G;G:G)
=СЧЁТЕСЛИМН(C:C;C:C;D:D;D:D)
=СЧЁТЕСЛИМН(C:C;C:C;E:E;E:E)
=СЧЁТЕСЛИМН(C:C;C:C;F:F;F:F)
=СЧЁТЕСЛИМН(C:C;C:C;G:G;G:G)
=СЧЁТЕСЛИМН(D:D;D:D;E:E;E:E)
=СЧЁТЕСЛИМН(D:D;D:D;F:F;F:F)
=СЧЁТЕСЛИМН(D:D;D:D;G:G;G:G)
=СЧЁТЕСЛИМН(E:E;E:E;F:F;F:F)
=СЧЁТЕСЛИМН(E:E;E:E;G:G;G:G)
=СЧЁТЕСЛИМН(F:F;F:F;G:G;G:G)

=СЧЁТЕСЛИМН(A:A;A:A;D:D;D:D;F:F;F:F)

=ЛЕВСИМВ(A1&ПОВТОР(0;D1);D1-ДЛСТР(ПРАВСИМВ(B1;D1)))&ПРАВСИМВ(B1;D1)

=СУММЕСЛИМН(Январь!C:C;Январь!B:B;B:B)+СУММЕСЛИМН(Февраль!D:D;Февраль!C:C;B:B)+СУММЕСЛИМН(Март!H:H;Март!G:G;B:B)+СУММЕСЛИМН(Апрель!E:E;Апрель!D:D;B:B)+СУММЕСЛИМН(Май!E:E;Май!D:D;B:B)+СУММЕСЛИМН(Июнь!E:E;Июнь!D:D;B:B)

=СУММЕСЛИМН(Январь!B:B;Январь!A:A;$B:$B)+СУММЕСЛИМН(Февраль!B:B;Февраль!A:A;$B:$B)+СУММЕСЛИМН(Март!B:B;Март!A:A;$B:$B)+СУММЕСЛИМН(Апрель!B:B;Апрель!A:A;$B:$B)+СУММЕСЛИМН(Май!B:B;Май!A:A;$B:$B)+СУММЕСЛИМН(Июнь!B:B;Июнь!A:A;$B:$B)

=СУММ(D4:J4)

Sub Сумма_листов()
    Dim cs As Range
    For Each cs In Intersect(Sheets("Свод").UsedRange, Sheets("Свод").Columns("B:B")).Cells
        If Not IsEmpty(cs.Value) Then
            SumCell cs
        End If
    Next
End Sub

Private Sub SumCell(cs As Range)
    Dim sh As Worksheet, arr As Variant, cf As Range, ya As Long
    ReDim arr(1 To cs.Parent.Parent.Sheets.Count)
    For Each sh In cs.Parent.Parent.Sheets
        If sh.Index <> cs.Parent.Index Then
            Set cf = sh.Cells.Find(cs.Value)
            If Not cf Is Nothing Then
                ya = ya + 1
                arr(ya) = "'" & sh.Name & "'!" & cf.Cells(1, 2).Address(0, 0, xlA1)
                
                Set cf = Nothing
            End If
        End If
    Next
    If ya > 0 Then
        ReDim Preserve arr(1 To ya)
        cs.Cells(1, 2).Formula = "=" & Join(arr, "+")
    Else
        cs.Cells(1, 2).Value = Empty
    End If
End Sub

Sub myUnion()
    CloseEmptyWb
    ActiveSheet.Copy
    Dim sh As Worksheet
    Set sh = ActiveSheet
    
    Dim arr As Variant
    arr = sh.UsedRange
    
    Dim dicFio As Object
    Set dicFio = GetFioDic(arr)
    arr = GetOutputArray(dicFio, arr)
    PrintArray arr, sh
End Sub

Private Function GetFioDic(arr As Variant) As Object
    Dim dic As Object, fioDic As Object
    Set fioDic = CreateObject("Scripting.Dictionary")
    Dim ya As Long
    For ya = 2 To UBound(arr, 1)
        If Not IsEmpty(arr(ya, 4)) Then
            If fioDic.Exists(arr(ya, 4)) Then
                Set dic = fioDic(arr(ya, 4))
            Else
                Set dic = CreateObject("Scripting.Dictionary")
            End If
            dic(ya) = Empty
            Set fioDic(arr(ya, 4)) = dic
        End If
    Next
    Set GetFioDic = fioDic
End Function
    
Private Function GetOutputArray(dicFio As Object, arr As Variant) As Variant
    Dim yc As Long, yb As Long, vy As Variant, crr As Variant, fio As Variant, xa As Long, flag As Boolean, dic As Object
    ReDim crr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    yc = 1
    For xa = 1 To UBound(arr, 2)
        crr(yc, xa) = arr(1, xa)
    Next
    For Each fio In dicFio
        yc = yc + 1
        Set dic = dicFio(fio)
        ReDim brr(0 To dic.Count - 1)
        For xa = 1 To UBound(arr, 2)
            If xa >= 4 And xa <= 8 Then
                vy = dic.Keys()(0)
                crr(yc, xa) = arr(vy, xa)
            Else
                flag = False
                yb = LBound(brr) - 1
                For Each vy In dic
                    yb = yb + 1
                    brr(yb) = arr(vy, xa)
                    If Not IsEmpty(arr(vy, xa)) Then flag = True
                Next
                If flag Then crr(yc, xa) = Join(brr, ";")
            End If
        Next
    Next
    GetOutputArray = crr
End Function
    
Private Sub PrintArray(arr As Variant, sh As Worksheet)
    sh.Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

Private Sub CloseEmptyWb()
    Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.Path = "" Then wb.Close False
    Next
End Sub

=ЕСЛИ(СМЕЩ('Данные в столбце'!$C$2;СТОЛБЕЦ()-1;0)=0;"";СМЕЩ('Данные в столбце'!$C$2;СТОЛБЕЦ()-1;0))

=ЕСЛИ(СМЕЩ('Данные в столбце'!$C$2;СТОЛБЕЦ()-1;0)=0;"";СМЕЩ('Данные в столбце'!$B$2;СТОЛБЕЦ()-1;0)-СМЕЩ('Данные в столбце'!$A$2;СТОЛБЕЦ()-1;0))

=СМЕЩ('Данные в столбце'!$C$2;СТОЛБЕЦ()-1;0)

=СМЕЩ('Данные в столбце'!$B$2;СТОЛБЕЦ()-1;0)-СМЕЩ('Данные в столбце'!$A$2;СТОЛБЕЦ()-1;0)