E2:E3132    =--(СЧЁТЕСЛИМН(A2:A$3132;A2;D2:D$3132;D2)=1)
H1          =СУММЕСЛИМН(E:E;A:A;G1)

Option Explicit

Sub Transform1C()
    CloseEmptyWb
    Dim arr As Variant
    arr = Intersect(Selection, ActiveSheet.UsedRange).Areas(1).Columns(1).Resize(, 2).Value
    
    Dim brr As Variant
    brr = GetFlatArray(arr)
    If IsEmpty(brr) Then Exit Sub
    PrintArray brr
End Sub

Private Sub PrintArray(arr As Variant)
    With Workbooks.Add(1)
        With .Sheets(1)
            With .Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
                .Value = arr
                .Rows(1).Font.Bold = True
            End With
        End With
        .Saved = True
    End With
End Sub

Private Function GetFlatArray(arr As Variant) As Variant
    Dim dicX As Object
    Set dicX = CreateObject("Scripting.Dictionary")
    
    Dim dicY As Object
    Set dicY = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        If IsSklad(arr(ya, 2)) Then
            If Not dicX.Exists(arr(ya, 1)) Then dicX.Item(arr(ya, 1)) = dicX.Count + 2
        Else
            If Not dicY.Exists(arr(ya, 1)) Then dicY.Item(arr(ya, 1)) = dicY.Count + 2
        End If
    Next
    
    If dicX.Count = 0 Then Exit Function
    If dicY.Count = 0 Then Exit Function
    
    Dim xb As Long
    Dim yb As Long
    Dim brr As Variant
    ReDim brr(1 To dicY.Items()(dicY.Count - 1), 1 To dicX.Items()(dicX.Count - 1))
    brr(1, 1) = "Продукция"
    For yb = 0 To dicY.Count - 1
        brr(dicY.Items()(yb), 1) = dicY.Keys()(yb)
    Next
    For yb = 0 To dicX.Count - 1
        brr(1, dicX.Items()(yb)) = dicX.Keys()(yb)
    Next
    
    
    For ya = 1 To UBound(arr, 1)
        yb = 0
        If IsSklad(arr(ya, 2)) Then
            xb = dicX.Item(arr(ya, 1))
        Else
            yb = dicY.Item(arr(ya, 1))
        End If
        If yb > 0 Then
            If xb > 0 Then
                If IsNumeric(arr(ya, 2)) Then
                    brr(yb, xb) = brr(yb, xb) + arr(ya, 2)
                End If
            End If
        End If
    Next
    
    GetFlatArray = brr
End Function

Private Function IsSklad(ByVal ss As String) As Boolean
    Select Case ss
    Case "", "Кол-во"
        IsSklad = True
    End Select
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

=ВПР(B2;[1PK.xlsx]Лист1!$B:$D;3;1)

Option Explicit

Private Const findString = "сентябрь 2024"

Sub myInsertRows()
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Sheets
        InsertRowsSheetJob sh
    Next
End Sub

Private Sub InsertRowsSheetJob(sh As Worksheet)
    Dim rr As Range
    On Error Resume Next
    Set rr = sh.UsedRange.Find(What:=findString, LookIn:=xlValues, LookAt:=xlWhole)
    On Error GoTo 0
    If rr Is Nothing Then Exit Sub
    
    Dim rf As Range
    Set rf = rr.End(xlDown)
    If rf.Row = rf.Parent.Rows.Count Then Exit Sub
    
    Dim ra As Range
    With sh
        Set ra = .Range(rr, rf).EntireRow
    End With
    InsertRowsRangeJob ra
End Sub

Private Sub InsertRowsRangeJob(rr As Range)
    rr.Copy
    rr.Rows(1 + rr.Rows.Count).Resize(rr.Rows.Count).Insert Shift:=xlDown
    Application.CutCopyMode = False
    
    Dim rt As Range
    Set rt = rr.Rows(1 + rr.Rows.Count).Resize(rr.Rows.Count)
    On Error Resume Next
    rt.SpecialCells(xlCellTypeConstants).ClearContents
    On Error GoTo 0
    rt.Calculate
End Sub

Private Const myColumn = "E:E,G:G"

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Cells.CountLarge > 1 Then Exit Sub

If Intersect(Target, Range(myColumn)) Is Nothing Then Exit Sub

On Error Resume Next

Dim dValue As Double

dValue = Target.Value

Application.ScreenUpdating = False

Application.EnableEvents = False

Application.Undo

Target.Value = Target.Value + dValue

Application.EnableEvents = True

Application.ScreenUpdating = True

On Error GoTo 0

End Sub

=(резка!H5>0)*резка!H5*0,05+(резка!H6>0)*резка!H6*15,1+(резка!H7>0)*резка!H7*11,7+(резка!H8>0)*резка!H8*7+(резка!H9>0)*резка!H9*0,22+(резка!H10>0)*резка!H10*6,8+(резка!H11>0)*резка!H11*0,11+(резка!H12>0)*резка!H12*0,11+(резка!H13>0)*резка!H13*4,93+(резка!H14>0)*резка!H14*0,05+(резка!H15>0)*резка!H15*0,23+(резка!H16>0)*резка!H16*0,02+(резка!H17>0)*резка!H17*0,015+(резка!H18>0)*резка!H18*0,015+(резка!H19>0)*резка!H19*0,02+(резка!H20>0)*резка!H20*0,2+(резка!H21>0)*резка!H21*0,34+(резка!H22>0)*резка!H22*0,01+(резка!H23>0)*резка!H23*0,12+(резка!H24>0)*резка!H24*0,02+(резка!H25>0)*резка!H25*0,26+(резка!H26>0)*резка!H26*2,2+(резка!H27>0)*резка!H27*0,33+(резка!H28>0)*резка!H28*0,4+(резка!H29>0)*резка!H29*0,11+(резка!H30>0)*резка!H30*0,23+(резка!H31>0)*резка!H31*0,02+(резка!H32>0)*резка!H32*0,05+(резка!H33>0)*резка!H33*0,02+(резка!H34>0)*резка!H34*0,012+(резка!H35>0)*резка!H35*0,02+(резка!H37>0)*резка!H37*0,052+(резка!H40>0)*резка!H40*3,42+(резка!H41>0)*резка!H41*0,12+(резка!H42>0)*резка!H42*2,14+(резка!H43>0)*резка!H43*0,03+(резка!H44>0)*резка!H44*0,09+(резка!H45>0)*резка!H45*0,002

=(ОСТАТ(ЦЕЛОЕ((B1-1/3)*2);16)=0)*2238+(ОСТАТ(ЦЕЛОЕ((B1-1/3)*2);16)=1)*2237+(ОСТАТ(ЦЕЛОЕ((B1-1/3)*2);16)=2)*2235+(ОСТАТ(ЦЕЛОЕ((B1-1/3)*2);16)=3)*2236
+(ОСТАТ(ЦЕЛОЕ((B1-1/3)*2);16)=4)*2235+(ОСТАТ(ЦЕЛОЕ((B1-1/3)*2);16)=5)*2236+(ОСТАТ(ЦЕЛОЕ((B1-1/3)*2);16)=6)*2237+(ОСТАТ(ЦЕЛОЕ((B1-1/3)*2);16)=7)*2238
+(ОСТАТ(ЦЕЛОЕ((B1-1/3)*2);16)=8)*2237+(ОСТАТ(ЦЕЛОЕ((B1-1/3)*2);16)=9)*2238+(ОСТАТ(ЦЕЛОЕ((B1-1/3)*2);16)=10)*2236+(ОСТАТ(ЦЕЛОЕ((B1-1/3)*2);16)=11)*2235
+(ОСТАТ(ЦЕЛОЕ((B1-1/3)*2);16)=12)*2236+(ОСТАТ(ЦЕЛОЕ((B1-1/3)*2);16)=13)*2235+(ОСТАТ(ЦЕЛОЕ((B1-1/3)*2);16)=14)*2238+(ОСТАТ(ЦЕЛОЕ((B1-1/3)*2);16)=15)*2237

Function НАИВРЕМЯ(время_наибольших_загрузок As String) As String
    Dim arr As Variant
    Dim brr As Variant
    Dim crr As Variant
    arr = Split(время_наибольших_загрузок, ";")
    If LBound(arr) > UBound(arr) Then Exit Function
    ReDim crr(LBound(arr) To UBound(arr))
    Dim ia As Long
    For ia = LBound(arr) To UBound(arr)
        brr = Split(Trim(arr(ia)), "-")
        crr(ia) = brr
    Next
    
    Dim drr As Variant
    ReDim drr(LBound(arr) To UBound(arr) + 1)
    drr(0) = Array(0, CDate(crr(0)(0)) - TimeSerial(0, 0, 1))
    For ia = LBound(arr) + 1 To UBound(arr)
        drr(ia) = Array(CDate(crr(ia - 1)(1)) + TimeSerial(0, 0, 1), CDate(crr(ia)(0)) - TimeSerial(0, 0, 1))
    Next
    drr(UBound(drr)) = Array(CDate(crr(ia - 1)(1)) + TimeSerial(0, 0, 1), 1 - TimeSerial(0, 0, 1))
    
    Dim ib As Long
    For ia = LBound(drr) To UBound(drr)
        For ib = LBound(drr(ia)) To UBound(drr(ia))
            drr(ia)(ib) = Format(drr(ia)(ib), "hh:mm:ss")
        Next
    Next
    
    Dim frr As Variant
    ReDim frr(LBound(drr) To UBound(drr))
    For ia = LBound(drr) To UBound(drr)
        frr(ia) = Join(drr(ia), "-")
    Next
    
    НАИВРЕМЯ = Join(frr, ";")
End Function

=ЕСЛИОШИБКА(1/(1/
((ОСТАТ(ЦЕЛОЕ($F4571-1/3);8)=0)*((A$1="2235")*0+(A$1="2236")*4+(A$1="2237")*7,25+(A$1="2238")*11,25)
+(ОСТАТ(ЦЕЛОЕ($F4571-1/3);8)=1)*((A$1="2235")*11,25+(A$1="2236")*11,25+(A$1="2237")*0+(A$1="2238")*0)
+(ОСТАТ(ЦЕЛОЕ($F4571-1/3);8)=2)*((A$1="2235")*11,25+(A$1="2236")*7,25+(A$1="2237")*0+(A$1="2238")*4)
+(ОСТАТ(ЦЕЛОЕ($F4571-1/3);8)=3)*((A$1="2235")*0+(A$1="2236")*0+(A$1="2237")*11,25+(A$1="2238")*11,25)
+(ОСТАТ(ЦЕЛОЕ($F4571-1/3);8)=4)*((A$1="2235")*4+(A$1="2236")*0+(A$1="2237")*11,25+(A$1="2238")*7,25)
+(ОСТАТ(ЦЕЛОЕ($F4571-1/3);8)=5)*((A$1="2235")*11,25+(A$1="2236")*11,25+(A$1="2237")*0+(A$1="2238")*0)
+(ОСТАТ(ЦЕЛОЕ($F4571-1/3);8)=6)*((A$1="2235")*7,25+(A$1="2236")*11,25+(A$1="2237")*4+(A$1="2238")*0)
+(ОСТАТ(ЦЕЛОЕ($F4571-1/3);8)=7)*((A$1="2235")*0+(A$1="2236")*0+(A$1="2237")*11,25+(A$1="2238")*11,25)));"В")

=ЕСЛИОШИБКА(1/(1/
((ОСТАТ(ЦЕЛОЕ(F4571-1/3);8)=0)*(($J$1=2235)*0+($J$1=2236)*4+($J$1=2237)*7,25+($J$1=2238)*11,25)
+(ОСТАТ(ЦЕЛОЕ(F4571-1/3);8)=1)*(($J$1=2235)*11,25+($J$1=2236)*11,25+($J$1=2237)*0+($J$1=2238)*0)
+(ОСТАТ(ЦЕЛОЕ(F4571-1/3);8)=2)*(($J$1=2235)*11,25+($J$1=2236)*7,25+($J$1=2237)*0+($J$1=2238)*4)
+(ОСТАТ(ЦЕЛОЕ(F4571-1/3);8)=3)*(($J$1=2235)*0+($J$1=2236)*0+($J$1=2237)*11,25+($J$1=2238)*11,25)
+(ОСТАТ(ЦЕЛОЕ(F4571-1/3);8)=4)*(($J$1=2235)*4+($J$1=2236)*0+($J$1=2237)*11,25+($J$1=2238)*7,25)
+(ОСТАТ(ЦЕЛОЕ(F4571-1/3);8)=5)*(($J$1=2235)*11,25+($J$1=2236)*11,25+($J$1=2237)*0+($J$1=2238)*0)
+(ОСТАТ(ЦЕЛОЕ(F4571-1/3);8)=6)*(($J$1=2235)*7,25+($J$1=2236)*11,25+($J$1=2237)*4+($J$1=2238)*0)
+(ОСТАТ(ЦЕЛОЕ(F4571-1/3);8)=7)*(($J$1=2235)*0+($J$1=2236)*0+($J$1=2237)*11,25+($J$1=2238)*11,25)));"В")

=ЕСЛИОШИБКА(1/(1/
((ОСТАТ($D2;8)=0)*(($H$1=2235)*0+($H$1=2236)*4+($H$1=2237)*7,25+($H$1=2238)*11,25)
+(ОСТАТ($D2;8)=1)*(($H$1=2235)*11,25+($H$1=2236)*11,25+($H$1=2237)*0+($H$1=2238)*0)
+(ОСТАТ($D2;8)=2)*(($H$1=2235)*11,25+($H$1=2236)*7,25+($H$1=2237)*0+($H$1=2238)*4)
+(ОСТАТ($D2;8)=3)*(($H$1=2235)*0+($H$1=2236)*0+($H$1=2237)*11,25+($H$1=2238)*11,25)
+(ОСТАТ($D2;8)=4)*(($H$1=2235)*4+($H$1=2236)*0+($H$1=2237)*11,25+($H$1=2238)*7,25)
+(ОСТАТ($D2;8)=5)*(($H$1=2235)*11,25+($H$1=2236)*11,25+($H$1=2237)*0+($H$1=2238)*0)
+(ОСТАТ($D2;8)=6)*(($H$1=2235)*7,25+($H$1=2236)*11,25+($H$1=2237)*4+($H$1=2238)*0)
+(ОСТАТ($D2;8)=7)*(($H$1=2235)*0+($H$1=2236)*0+($H$1=2237)*11,25+($H$1=2238)*11,25)));"В")

=ДАТАЗНАЧ(ЛЕВСИМВ(J4;НАЙТИ("-";J4)-1))

Sub myReplace()
    Dim cl As Range
    For Each cl In Intersect(Selection, ActiveSheet.UsedRange).Cells
        cl.Value = GetReplacedString(cl.Value)
    Next
End Sub

Function GetReplacedString(ByVal ss As String) As String
    ss = Replace(ss, vbCr, "")
    ss = Replace(ss, vbLf, "")
    ss = Replace(ss, "Titel: ", "!Titel: !")
    ss = Replace(ss, "Bullets:", "!Bullets:!")
    ss = Replace(ss, "Beschreibung:", "!Beschreibung:!")
    ss = Replace(ss, "-Из Металла", "!-Из Металла!")
    
    GetReplacedString = ss
End Function

=ЕСЛИОШИБКА(1/(1/
((ОСТАТ(AL$31;8)=0)*(($A33=2235)*0+($A33=2236)*4+($A33=2237)*7,25+($A33=2238)*11,25)
+(ОСТАТ(AL$31;8)=1)*(($A33=2235)*11,25+($A33=2236)*11,25+($A33=2237)*0+($A33=2238)*0)
+(ОСТАТ(AL$31;8)=2)*(($A33=2235)*11,25+($A33=2236)*7,25+($A33=2237)*0+($A33=2238)*4)
+(ОСТАТ(AL$31;8)=3)*(($A33=2235)*0+($A33=2236)*0+($A33=2237)*11,25+($A33=2238)*11,25)
+(ОСТАТ(AL$31;8)=4)*(($A33=2235)*4+($A33=2236)*0+($A33=2237)*11,25+($A33=2238)*7,25)
+(ОСТАТ(AL$31;8)=5)*(($A33=2235)*11,25+($A33=2236)*11,25+($A33=2237)*0+($A33=2238)*0)
+(ОСТАТ(AL$31;8)=6)*(($A33=2235)*7,25+($A33=2236)*11,25+($A33=2237)*4+($A33=2238)*0)
+(ОСТАТ(AL$31;8)=7)*(($A33=2235)*0+($A33=2236)*0+($A33=2237)*11,25+($A33=2238)*11,25)));"В")

F4:F14    =ВПР(ДАТАЗНАЧ(B4);I:K;3;1)
I4:I6    =ДАТАЗНАЧ(ПРАВСИМВ(J4;10))

'v2
Function СМЕНА(дата As Date) As Long
    Dim brr As Variant
    ReDim brr(2219 To 2222) As Date
    
    'Первая дневная смена.
    brr(2219) = "06.05.2024"
    brr(2220) = "02.05.2024"
    brr(2221) = "08.05.2024"
    brr(2222) = "04.05.2024"
    
    Dim dateMod As Byte
    dateMod = DateToLong(дата) Mod 16
    
    Dim dd As Double
    Dim delt As Variant
    Dim ib As Long
    For ib = LBound(brr) To UBound(brr)
        dd = brr(ib) + 1 / 3
        dd = DateToLong(dd)
        For Each delt In Array(0, 2, 9, 11)
            If (dd + delt) Mod 16 = dateMod Then
                СМЕНА = ib
                Exit Function
            End If
        Next
    Next
    
End Function

Private Function DateToLong(ByVal dt As Date) As Long
    Dim res As Double
    res = (dt - DateSerial(2024, 5, 1) - 1 / 3)
    res = res * 2
    res = Int(res)
    DateToLong = res
End Function

=(ОСТАТ(ЦЕЛОЕ((F2-1/3)*2);16)=0)*2222+(ОСТАТ(ЦЕЛОЕ((F2-1/3)*2);16)=1)*2221+(ОСТАТ(ЦЕЛОЕ((F2-1/3)*2);16)=2)*2222+(ОСТАТ(ЦЕЛОЕ((F2-1/3)*2);16)=3)*2221
+(ОСТАТ(ЦЕЛОЕ((F2-1/3)*2);16)=4)*2219+(ОСТАТ(ЦЕЛОЕ((F2-1/3)*2);16)=5)*2220+(ОСТАТ(ЦЕЛОЕ((F2-1/3)*2);16)=6)*2219+(ОСТАТ(ЦЕЛОЕ((F2-1/3)*2);16)=7)*2220
+(ОСТАТ(ЦЕЛОЕ((F2-1/3)*2);16)=8)*2221+(ОСТАТ(ЦЕЛОЕ((F2-1/3)*2);16)=9)*2221+(ОСТАТ(ЦЕЛОЕ((F2-1/3)*2);16)=10)*2221+(ОСТАТ(ЦЕЛОЕ((F2-1/3)*2);16)=11)*2222
+(ОСТАТ(ЦЕЛОЕ((F2-1/3)*2);16)=12)*2220+(ОСТАТ(ЦЕЛОЕ((F2-1/3)*2);16)=13)*2219+(ОСТАТ(ЦЕЛОЕ((F2-1/3)*2);16)=14)*2220+(ОСТАТ(ЦЕЛОЕ((F2-1/3)*2);16)=15)*2219

=СМЕНА(F2)

Function СМЕНА(дата As String) As Long
    
    Dim dt As Date
    dt = CDate(дата)
    
    Dim arr As Variant
    ReDim arr(1 To 16)
    arr(1) = 1
    arr(3) = 1
    arr(10) = 1
    arr(12) = 1
    
    Dim brr As Variant
    ReDim brr(1 To 1000, 1 To 2)
    
    brr(1, 1) = DateSerial(2024, 4, 26) + 8 / 24
    Dim ya As Long
    Dim yb As Long
    For yb = 2 To UBound(brr, 1)
        brr(yb, 1) = brr(yb - 1, 1) + 12 / 24
    Next
    
    yb = 1
    Do
        For ya = 1 To UBound(arr, 1)
            If arr(ya) = 1 Then brr(yb, 2) = 2222
            yb = yb + 1
            If yb > UBound(brr, 1) Then Exit Do
        Next
    Loop

    yb = 9
    Do
        For ya = 1 To UBound(arr, 1)
            If arr(ya) = 1 Then brr(yb, 2) = brr(yb, 2) + 2221
            yb = yb + 1
            If yb > UBound(brr, 1) Then Exit Do
        Next
    Loop

    yb = 13
    Do
        For ya = 1 To UBound(arr, 1)
            If arr(ya) = 1 Then brr(yb, 2) = brr(yb, 2) + 2220
            yb = yb + 1
            If yb > UBound(brr, 1) Then Exit Do
        Next
    Loop

    yb = 5
    Do
        For ya = 1 To UBound(arr, 1)
            If arr(ya) = 1 Then brr(yb, 2) = brr(yb, 2) + 2219
            yb = yb + 1
            If yb > UBound(brr, 1) Then Exit Do
        Next
    Loop
    
    For yb = 1 To UBound(brr, 1) - 1
        If dt >= brr(yb, 1) And dt < brr(yb + 1, 1) Then
            СМЕНА = brr(yb, 2)
            Exit Function
        End If
    Next
End Function