Public ProcessCount As Long

=ДВССЫЛ(ДВССЫЛ(СЖПРОБЕЛЫ(ЛЕВСИМВ(ПОДСТАВИТЬ(ЯЧЕЙКА("адрес");"$";ПОВТОР(" ";10));20))&20*ЦЕЛОЕ(СТРОКА()/20)+9))

=ДВССЫЛ(ДВССЫЛ("C"&20*ЦЕЛОЕ(СТРОКА()/20)+9))

=ДВССЫЛ($C$9)

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("A1")) Is Nothing Then
        Select Case Range("A1").Value
        Case "Значение1", "Значение2"
            'А4-А6 не изменияются
        Case "Значение3", "Значение4"
            'А5,А6 скрываются
            Range("A5:A6").EntireRow.Hidden = True
        Case "Значение5", "Значение6"
            'А4,А5 скрываются
            Range("A4:A5").EntireRow.Hidden = True
        Case Else
            Range("A4:A6").EntireRow.Hidden = False
        End Select
    End If
End Sub

    Set shSource = Workbooks("?????? 1 (1).xlsx").Sheets("????1")
    Set shTarget = Workbooks("?????? 2.xlsx").Sheets("????1")

    Set shSource = Workbooks("Пример 1 (1).xlsx").Sheets("Лист1")
    Set shTarget = Workbooks("ПРимер 2.xlsx").Sheets("Лист1")

Option Explicit

Sub Перебор_рекурсивный()
    PereborRangeRecu Columns("A:C"), Columns("E:E"), Columns("G:I"), Columns("K:K")
End Sub

Private Sub PereborRangeRecu(ra As Range, rb As Range, printA As Variant, printB As Variant)
    Dim aic As Variant
    aic = GetAllValueFromRange(ra)
    Dim bic As Variant
    bic = GetAllValueFromRange(rb)
    
    Dim yp As Long
    yp = UBound(aic) + 1
    yp = yp * (UBound(bic) + 1)
    
    Dim pra As Variant, prb As Variant
    ReDim pra(1 To yp, 1 To UBound(FromKey(aic(0))) + 1)
    ReDim prb(1 To yp, 1 To UBound(FromKey(bic(0))) + 11)
    
    Dim aa As Variant, bb As Variant, arr As Variant, xp As Long
    yp = 0
    For Each aa In aic
        For Each bb In bic
            yp = yp + 1
            arr = FromKey(aa)
            For xp = 1 To UBound(arr) + 1
                pra(yp, xp) = arr(xp - 1)
            Next
        
            arr = FromKey(bb)
            For xp = 1 To UBound(arr) + 1
                prb(yp, xp) = arr(xp - 1)
            Next
        Next
    Next
    
    printA.Resize(1, UBound(pra, 2)).EntireColumn.ClearContents
    printB.Resize(1, UBound(prb, 2)).EntireColumn.ClearContents
    
    printA.Resize(UBound(pra, 1), UBound(pra, 2)).Value = pra
    printB.Resize(UBound(prb, 1), UBound(prb, 2)).Value = prb
End Sub

Private Function GetAllValueFromRange(ra As Range) As Variant
    Dim arr As Variant
    arr = GetResizedArrayValue(ra)

    Dim dic As Object, sKey As String
    Set dic = CreateObject("Scripting.Dictionary")
    Dim ya As Long
    For ya = 1 To UBound(arr, 1)
        sKey = GetKey2(arr, ya)
        dic(sKey) = Empty
    Next
    
    Dim brr As Variant
    brr = dic.Keys()
    Set dic = CreateObject("Scripting.Dictionary")
    FillByRecu dic, brr
    brr = RemoveDup(dic.Keys())
    
    Set dic = CreateObject("Scripting.Dictionary")
    Dim vb As Variant, vc As Variant, crr As Variant, summed As Variant, hasEmpty As Boolean
    For Each vb In brr
        crr = FromKey(vb)
        ReDim summed(0 To UBound(arr, 2) - 1)
        For Each vc In crr
            sumArrays summed, FromKey(GetKey2(arr, CLng(vc) + 1))
        Next
        hasEmpty = False
        For Each vc In summed
            If vc = "" Then
                hasEmpty = True
                Exit For
            End If
        Next
        If Not hasEmpty Then
            sKey = GetKey1(summed)
            dic(sKey) = Empty
        End If
    Next
    
    GetAllValueFromRange = dic.Keys
End Function

Private Sub sumArrays(summed As Variant, arr As Variant)
    Dim ya As Long
    For ya = LBound(arr) To UBound(arr)
        If IsEmpty(summed(ya)) Or summed(ya) = "" Then
            summed(ya) = arr(ya)
        End If
    Next
End Sub

Private Function RemoveDup(arr As Variant) As Variant
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim bic As Object
    Set bic = CreateObject("Scripting.Dictionary")
    
    Dim va As Variant, vb As Variant, hasDupies As Boolean
    For Each va In arr
        hasDupies = False
        Set bic = CreateObject("Scripting.Dictionary")
        For Each vb In FromKey(va)
            If bic.Exists(vb) Then
                hasDupies = True
                Exit For
            Else
                bic(vb) = Empty
            End If
        Next
        If Not hasDupies Then dic(va) = Empty
    Next
    
    RemoveDup = dic.Keys()
End Function

Private Sub FillByRecu(dic As Object, arr As Variant)
    Dim ind As Variant, sKey As String
    ReDim ind(LBound(arr) To UBound(arr)) As Long
    
    Do
        sKey = GetKey1(ind)
        dic(sKey) = Empty
        recuPlus ind, LBound(ind)
        If ind(UBound(ind)) > UBound(ind) Then Exit Do
        DoEvents
    Loop
End Sub

Private Sub recuPlus(ind As Variant, level As Long)
    ind(level) = ind(level) + 1
    If ind(level) > UBound(ind) Then
        If level = UBound(ind) Then
            
        Else
            Dim xi As Long
            For xi = LBound(ind) To level
                ind(level) = 0
            Next
            recuPlus ind, level + 1
        End If
    End If
End Sub

Private Function GetKey1(brr As Variant) As String
    Dim arr As Variant
    ReDim arr(LBound(brr) To UBound(brr)) As String
    Dim xa As Long
    For xa = LBound(arr) To UBound(arr)
        arr(xa) = brr(xa)
    Next
    GetKey1 = Join(arr, "|")
End Function
Private Function GetKey2(arr As Variant, ya As Long) As String
    Dim brr As Variant
    ReDim brr(LBound(arr, 2) To UBound(arr, 2))
    Dim xa As Long
    For xa = LBound(arr, 2) To UBound(arr, 2)
        brr(xa) = arr(ya, xa)
    Next
    GetKey2 = Join(brr, "|")
End Function

Private Function FromKey(ByVal sKey As String) As Variant
    FromKey = Split(sKey, "|")
End Function

Private Function GetResizedArrayValue(rr As Range) As Variant
    Dim arr As Variant
    arr = Intersect(rr, rr.Parent.UsedRange).Value
    
    Dim yMax As Long, ya As Long, xa As Long
    For xa = 1 To UBound(arr, 2)
        For ya = UBound(arr, 1) To 1 Step -1
            If Not IsEmpty(arr(ya, xa)) Then
                If yMax < ya Then
                    yMax = ya
                    If yMax = UBound(arr, 1) Then GoTo FoundYmax
                End If
            End If
        Next
    Next
FoundYmax:
    Set rr = rr.Resize(yMax)
    If rr.Cells.CountLarge = 1 Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = rr.Value
    Else
        arr = rr.Value
    End If
    GetResizedArrayValue = arr
End Function

Sub Проверить()
    Dim shSource As Worksheet, shTarget As Worksheet
    Set shSource = Workbooks("Пример 1 (1).xlsx").Sheets("Лист1")
    Set shTarget = Workbooks("ПРимер 2.xlsx").Sheets("Лист1")
    
    Dim cs As Range, yt As Long
    For Each cs In shSource.UsedRange.Columns("A:A").Cells
        If cs.Row > 1 Then
            If Not IsEmpty(cs.Value) Then
                If cs.Columns("B:B").Value <> "*" Then
                    yt = 0
                    On Error Resume Next
                    yt = WorksheetFunction.Match(cs.Value, shTarget.Columns("A:A"), 0)
                    On Error GoTo 0
                    If yt = 0 Then
                        yt = shTarget.UsedRange.Row + shTarget.UsedRange.Rows.Count
                    End If
                    shTarget.Columns("A:A").Cells(yt, 1).Value = cs.Value
                    shTarget.Columns("B:B").Cells(yt, 1).Value = cs.Columns("B:B").Value
                End If
            End If
        End If
    Next
End Sub

shTarget.Range("J27").Formula = sFormula
shTarget.Range("J28").Formula = "=A1+1"
shTarget.Range("J29").Formula = "=A2*B3"

Option Explicit

Sub Перебор()
    PereborRange Columns("A:C"), Columns("E:E"), Columns("G:I"), Columns("K:K")
End Sub

Private Sub PereborRange(ra As Range, rb As Range, printA As Variant, printB As Variant)
    Dim aic As Variant
    aic = GetAllValueFromRange(ra)
    Dim bic As Variant
    bic = GetAllValueFromRange(rb)
    
    Dim yp As Long
    yp = UBound(aic) + 1
    yp = yp * (UBound(bic) + 1)
    
    Dim pra As Variant, prb As Variant
    ReDim pra(1 To yp, 1 To UBound(Split(aic(0), "#")) + 1)
    ReDim prb(1 To yp, 1 To UBound(Split(bic(0), "#")) + 1)
    
    Dim aa As Variant, bb As Variant, arr As Variant, xp As Long
    yp = 0
    For Each aa In aic
        For Each bb In bic
            yp = yp + 1
            arr = Split(aa, "#")
            For xp = 1 To UBound(arr) + 1
                pra(yp, xp) = arr(xp - 1)
            Next
        
            arr = Split(bb, "#")
            For xp = 1 To UBound(arr) + 1
                prb(yp, xp) = arr(xp - 1)
            Next
        Next
    Next
    
    printA.Resize(1, UBound(pra, 2)).EntireColumn.ClearContents
    printB.Resize(1, UBound(prb, 2)).EntireColumn.ClearContents
    
    printA.Resize(UBound(pra, 1), UBound(pra, 2)).Value = pra
    printB.Resize(UBound(prb, 1), UBound(prb, 2)).Value = prb
End Sub

Private Function GetAllValueFromRange(rr As Range) As Variant
    
    Dim arr As Variant
    arr = GetResizedArrayValue(rr)
    
    Dim rowsHasEmpty As Object
    Set rowsHasEmpty = CreateObject("Scripting.Dictionary")
    Dim ya As Long, xa As Long
    For xa = 1 To UBound(arr, 2)
        For ya = 1 To UBound(arr, 1)
            If IsEmpty(arr(ya, xa)) Then
                rowsHasEmpty(ya) = Empty
            End If
        Next
    Next
    
    Dim columnNoEmptyInEmptyRow As Object
    Set columnNoEmptyInEmptyRow = CreateObject("Scripting.Dictionary")
    Dim vy As Variant
    For Each vy In rowsHasEmpty
        For xa = 1 To UBound(arr, 2)
            If Not IsEmpty(arr(vy, xa)) Then
                columnNoEmptyInEmptyRow(xa) = Empty
            End If
        Next
    Next
    
    Dim fixed As Variant, sKey As String, fic As Object
    Set fic = CreateObject("Scripting.Dictionary")
    For ya = 1 To UBound(arr, 1)
        For xa = 1 To UBound(arr, 2)
            If Not IsEmpty(arr(ya, xa)) Then
                If Not columnNoEmptyInEmptyRow.Exists(xa) Then
                    GoTo HasFixedColumn
                End If
            End If
        Next
        GoTo NextYa
HasFixedColumn:
        ReDim fixed(1 To UBound(arr, 2))
        For xa = 1 To UBound(arr, 2)
            If Not columnNoEmptyInEmptyRow.Exists(xa) Then
                fixed(xa) = arr(ya, xa)
            End If
        Next
        sKey = Join(fixed, "#")
        fic(sKey) = Empty
NextYa:
    Next
    
    Dim eic As Object
    Set eic = CreateObject("Scripting.Dictionary")
    For ya = 1 To UBound(arr, 1)
        fixed = Empty
        
        For xa = 1 To UBound(arr, 2)
            If Not IsEmpty(arr(ya, xa)) Then
                If columnNoEmptyInEmptyRow.Exists(xa) Then
                    If IsEmpty(fixed) Then ReDim fixed(1 To UBound(arr, 2))
                    fixed(xa) = arr(ya, xa)
                End If
            End If
        Next
        If Not IsEmpty(fixed) Then
            sKey = Join(fixed, "#")
            eic(sKey) = Empty
        End If
    Next
    
    If eic.Count > 0 Then
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        Dim vv As Variant, ww As Variant, emted As Variant, sumed As Variant
        For Each vv In fic
            For Each ww In eic
                fixed = Split(vv, "#")
                emted = Split(ww, "#")
                sumed = SumArray(fixed, emted)
                sKey = Join(sumed, "#")
                dic(sKey) = Empty
            Next
        Next
        GetAllValueFromRange = dic.Keys()
    Else
        GetAllValueFromRange = fic.Keys()
    End If
    
End Function

Private Function SumArray(arr As Variant, brr As Variant) As Variant
    Dim srr As Variant, ys As Long
    ReDim srr(LBound(arr) To UBound(arr))
    For ys = LBound(srr) To UBound(srr)
        If arr(ys) <> "" Then
            srr(ys) = arr(ys)
        ElseIf brr(ys) <> "" Then
            srr(ys) = brr(ys)
        End If
    Next
    SumArray = srr
End Function

Private Function GetResizedArrayValue(rr As Range) As Variant
    Dim arr As Variant
    arr = Intersect(rr, rr.Parent.UsedRange).Value
    
    Dim yMax As Long, ya As Long, xa As Long
    For xa = 1 To UBound(arr, 2)
        For ya = UBound(arr, 1) To 1 Step -1
            If Not IsEmpty(arr(ya, xa)) Then
                If yMax < ya Then
                    yMax = ya
                    If yMax = UBound(arr, 1) Then GoTo FoundYmax
                End If
            End If
        Next
    Next
FoundYmax:
    Set rr = rr.Resize(yMax)
    If rr.Cells.CountLarge = 1 Then
        ReDim arr(1 To 1, 1 To 1)
        arr(1, 1) = rr.Value
    Else
        arr = rr.Value
    End If
    GetResizedArrayValue = arr
End Function

Option Explicit

Sub Лист_в_умную()
    CloseEmptyWb
    
    Dim sh As Worksheet
    If Cells(1, 1).Value = "<DATE>" Then
        Set sh = ActiveSheet
    Else
        Dim si As Worksheet
        For Each si In ActiveWorkbook.Worksheets
            If si.Cells(1, 1).Value = "<DATE>" Then
                Set sh = si
                GoTo ExitFor
            End If
        Next
        If sh Is Nothing Then
            Dim wb As Workbook
            For Each wb In Application.Workbooks
                For Each si In wb.Worksheets
                    If si.Cells(1, 1).Value = "<DATE>" Then
                        Set sh = si
                        GoTo ExitFor
                    End If
                Next
            Next
        End If
    End If
ExitFor:
    
    MakeListObjectFromPivotSheet sh
End Sub

Sub Сводную_в_умную()
    CloseEmptyWb
    
    Dim pt As PivotTable
    On Error Resume Next
    Set pt = ActiveSheet.PivotTables(1)
    If pt Is Nothing Then
        Dim wb As Workbook
        For Each wb In Application.Workbooks
            wb.Activate
            Set pt = ActiveSheet.PivotTables(1)
            If Not pt Is Nothing Then Exit For
        Next
    End If
    On Error GoTo 0
    
    MakeListObjectFromPivotTable pt
End Sub

Private Sub MakeListObjectFromPivotSheet(sh As Worksheet)
    Dim arr As Variant
    arr = GetArrFromSheet(sh)
    
    PrintArr arr, Workbooks.Add(1).Sheets(1).Cells(1, 1)
End Sub

Private Sub MakeListObjectFromPivotTable(pt As PivotTable)
    Dim arr As Variant
    arr = GetArr(pt)
    
    PrintArr arr, Workbooks.Add(1).Sheets(1).Cells(1, 1)
End Sub

Private Function GetArrFromSheet(sh As Worksheet) As Variant
    Dim arr As Variant
    arr = Intersect(sh.Columns("A:F"), sh.UsedRange).Value
    
    Dim dic As Object
    Set dic = GetDic(arr)
    If dic.Count = 0 Then Exit Function
    
    Dim yd As Long, yb As Long, sm As Long, yt As Long, xs As Long, xf As Long
    Dim brr As Variant, frr As Variant
    brr = dic.Items()(0).Items()(0).Items()(0)
    ReDim arr(1 To dic.Count + 1, 1 To 1 + 2 * (3 + UBound(brr) + 1))
    
    brr = Split("Дата,Сессия,Начало,Окончание,Открытие,Максимум,Минимум,Закрытие,Сессия 2,Начало 3,Окончание 4,Открытие 5,Максимум 6,Минимум 7,Закрытие 8", ",")
    For xs = 1 To UBound(brr)
        arr(1, xs) = brr(xs - 1)
    Next
    brr = Empty
    
    Dim bic As Object, cic As Object
    For yd = 0 To dic.Count - 1
        Set bic = dic.Items()(yd)
        For sm = 0 To bic.Count - 1
            Set cic = bic.Items()(sm)
            frr = cic.Items()(0)
            For yt = 1 To cic.Count - 1
                brr = cic.Items()(yt)
                
                If frr(1) < brr(1) Then frr(1) = brr(1)
                If frr(2) > brr(2) Then frr(2) = brr(2)
                frr(3) = brr(3)
            Next
            If bic.Keys()(sm) = "Дневная" Then
                xs = 2
            ElseIf bic.Keys()(sm) = "Вечерняя" Then
                xs = 2 + 3 + UBound(frr) + 1
            End If
            For xf = 0 To UBound(frr)
                arr(2 + yd, xs + xf + 3) = frr(xf)
            Next
            
            arr(2 + yd, xs + 1) = bic.Items()(sm).Keys()(0)
            arr(2 + yd, xs + 2) = bic.Items()(sm).Keys()(cic.Count - 1)
            arr(2 + yd, xs) = bic.Keys()(sm)
        Next
        arr(2 + yd, 1) = dic.Keys()(yd)
    Next
    GetArrFromSheet = arr
End Function

Private Function GetDic(arr As Variant) As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long, ss As String, dt As Date, tt As Date
    For ya = 2 To UBound(arr, 1)
        If IsNumeric(arr(ya, 1)) Then
            If IsNumeric(arr(ya, 2)) Then
                dt = 0
                tt = 0
                On Error Resume Next
                ss = Left(arr(ya, 1), 4) & "." & Mid(arr(ya, 1), 5, 2) & "." & Mid(arr(ya, 1), 7, 2)
                dt = DateValue(ss)
                ss = Left(arr(ya, 2), Len(arr(ya, 2)) - 4) & ":" & Mid(arr(ya, 2), Len(arr(ya, 2)) - 3, 2) & ":" & Right(arr(ya, 2), 2)
                tt = TimeValue(ss)
                On Error GoTo 0
                If dt > 0 And tt > 0 Then
                    If arr(ya, 2) >= 60000 And arr(ya, 2) < 190000 Then
                        ss = "Дневная"
                    Else
                        ss = "Вечерняя"
                    End If
                    If Not dic.Exists(dt) Then
                        Set dic(dt) = CreateObject("Scripting.Dictionary")
                    End If
                    If Not dic(dt).Exists(ss) Then
                        Set dic(dt)(ss) = CreateObject("Scripting.Dictionary")
                    End If
                    dic(dt)(ss)(tt) = Array(arr(ya, 3), arr(ya, 4), arr(ya, 5), arr(ya, 6))
                End If
            End If
        End If
    Next
    Set GetDic = dic
End Function

Private Function GetArr(pt As PivotTable) As Variant
    Dim arr As Variant, brr As Variant, ya As Long, yb As Long, xa As Long, xb As Long
    arr = pt.TableRange1.Value
    ReDim brr(1 To UBound(arr, 1), 1 To 2 * (UBound(arr, 2) - 1) + 1)
    
    Dim hrr As Variant
    hrr = Split("Дата Сессия Начало Окончание Открытие Максимум Минимум Закрытие Сессия2 Начало3 Окончание4 Открытие5 Максимум6 Минимум7 Закрытие8", " ")
    For xb = 1 To UBound(brr, 2)
        brr(1, xb) = hrr(xb - 1)
    Next
    
    yb = 1
    For ya = 2 To UBound(arr, 1)
        If Not IsEmpty(arr(ya, 1)) Then
            yb = yb + 1
            xb = 1
            brr(yb, xb) = arr(ya, 1)
            For xa = 2 To UBound(arr, 2)
                xb = xb + 1
                brr(yb, xb) = arr(ya, xa)
            Next
            If ya < UBound(arr, 1) Then
                If IsEmpty(arr(ya + 1, 1)) Then
                    For xa = 2 To UBound(arr, 2)
                        xb = xb + 1
                        brr(yb, xb) = arr(ya + 1, xa)
                    Next
                End If
            End If
        End If
    Next
    brr = ResizeArray(brr, yb)
    
    GetArr = brr
End Function

Private Function ResizeArray(arr, yNew As Long) As Variant
    Dim brr As Variant
    ReDim brr(1 To yNew, 1 To UBound(arr, 2))
    Dim yb As Long, xb As Long
    For yb = 1 To UBound(brr, 1)
    For xb = 1 To UBound(brr, 2)
        brr(yb, xb) = arr(yb, xb)
    Next
    Next
    ResizeArray = brr
End Function

Private Sub PrintArr(arr As Variant, rTarg As Range)
    Set rTarg = rTarg.Resize(UBound(arr, 1), UBound(arr, 2))
    rTarg.Value = arr
    
    Dim xx As Long, dx As Long
    dx = (rTarg.Columns.Count - 3) / 2 + 1
    For xx = 3 To 4
        rTarg.Columns(xx).NumberFormat = "hh:mm:ss;@"
        rTarg.Columns(xx + dx).NumberFormat = "hh:mm:ss;@"
    Next
    For xx = 5 To (rTarg.Columns.Count - 1) / 2 + 1
        rTarg.Columns(xx).NumberFormat = "#,##0"
        rTarg.Columns(xx + dx).NumberFormat = "#,##0"
    Next
    
    Dim sh As Worksheet
    Set sh = rTarg.Parent
    With sh.ListObjects.Add(xlSrcRange, rTarg, , xlYes)
        .Name = "Таблица1"
        .TableStyle = "TableStyleMedium2"
    End With
    Dim tb As ListObject
    Set tb = sh.ListObjects(1)
    rTarg.HorizontalAlignment = xlCenter
    rTarg.EntireColumn.AutoFit
    
'    Workbooks("Результат.xlsx").Sheets(1).UsedRange.Copy rTarg.Cells(rTarg.Rows.Count + 2, 1)
    
    sh.Parent.Saved = True
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

Option Explicit
'v2
Sub Преобразовать()
    Dim Application_Calculation As XlCalculation
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual

    CloseEmptyWb
    Dim shSource As Worksheet, shTarget As Worksheet, rTarget As Range
    Set shSource = ActiveSheet
    Set shTarget = Workbooks.Add(1).Sheets(1)
    Set rTarget = shTarget.Cells(1, 1)
     
    JobRange shSource.Rows("1:2"), rTarget
    Set rTarget = rTarget.Cells(2, 1)
     
    Dim r1 As Range, r2 As Range
    Dim xRange As Long, aRange As Variant
    aRange = Array("Расшифровка реализации", "Расшифровка реализации по виду оплаты", "Касса*", "Отчет составили и смену сдали:")
    For xRange = LBound(aRange) To UBound(aRange) - 1
    
        Set r1 = shSource.Cells.Find(aRange(xRange))
        Set r2 = shSource.Cells.Find(aRange(xRange + 1))
         
        Set r1 = shSource.Range(r1, r2.Cells(0, 1))
        JobRange r1.EntireRow, rTarget
    Next
    shTarget.Columns(1).AutoFit
'    shSource.Parent.Sheets(2).UsedRange.Copy shTarget.Cells(1, shTarget.UsedRange.Columns.Count + 2)
     
    Application.Calculation = Application_Calculation
    shTarget.Parent.Saved = True
End Sub
 
Private Sub JobRange(rSource As Range, rTarget As Range)
    Set rSource = Intersect(rSource, rSource.Parent.UsedRange)
     
    Dim ys As Long, yb As Long, xs As Long, xt As Long
    For xs = 1 To rSource.Columns.Count
        For ys = 1 To rSource.Rows.Count
            If rSource.Cells(ys, xs).Value <> "" Then Exit For
        Next
        If ys <= rSource.Rows.Count Then
            xt = xt + 1
            For yb = ys To rSource.Rows.Count
                rTarget.Cells(yb, xt).NumberFormat = "@"
                rTarget.Cells(yb, xt).Value = rSource.Cells(yb, xs).Value
            Next
        End If
        DoEvents
    Next
    Set rTarget = rTarget.Cells(rSource.Rows.Count + 1, 1)
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

Option Explicit

Sub Преобразовать()
    CloseEmptyWb
    Dim shSource As Worksheet, shTarget As Worksheet, rTarget As Range
    Set shSource = ActiveSheet
    Set shTarget = Workbooks.Add(1).Sheets(1)
    Set rTarget = shTarget.Cells(1, 1)
    
    JobRange shSource.Rows("1:2"), rTarget
    
    Dim r1 As Range, r2 As Range
    Set r1 = shSource.Cells.Find("Расшифровка реализации")
    Set r2 = shSource.Cells.Find("Итого передано наличных денег :")
    
    Set r1 = shSource.Range(r1, r2)
    
    JobRange r1.EntireRow, rTarget
End Sub

Private Sub JobRange(rSource As Range, rTarget As Range)
    Set rSource = Intersect(rSource, rSource.Parent.UsedRange)
    
    Dim ys As Long, xs As Long, xt As Long
    For ys = 1 To rSource.Rows.Count
        xs = 1
        xt = 1
        Do
            If xs > rSource.Columns.Count Then Exit Do
            If rSource.Cells(ys, xs).Value <> "" Then
                rTarget.Cells(ys, xt).Value = rSource.Cells(ys, xs).Value
                xt = xt + 1
            End If
            
            xs = xs + rSource.Cells(ys, xs).MergeArea.Columns.Count
            DoEvents
        Loop
    Next
    
    Set rTarget = rTarget.Cells(ys + 2, 1)
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

=СУММЕСЛИМН(Лист2!D:D;Лист2!A:A;A:A;Лист2!B:B;B:B)

Option Explicit

Sub Когорт_активлист()
    Dim rSource As Range, rTarget As Range
    Set rSource = Range("A1").CurrentRegion
    Set rTarget = rSource.Cells(rSource.Rows.Count + 3, 1)
    
    Cogort rSource, rTarget
End Sub

Private Sub Cogort(rSource As Range, rTarget As Range)
    Dim sor As Variant, ys As Long, xs As Long
    sor = rSource.Value
    
    For ys = 2 To UBound(sor, 1)
        sor(ys, 1) = Empty
    Next
    
    Dim tar As Variant
    ReDim tar(1 To 2 + UBound(sor, 2) - 2, 1 To UBound(sor, 2))
    
    Set rTarget = rTarget.Resize(UBound(tar, 1), UBound(tar, 2))
    
    tar(1, 1) = "Всего клиентов"
    For ys = 2 To UBound(sor, 1)
        For xs = 2 To UBound(sor, 2)
            If Not IsEmpty(sor(ys, xs)) Then
                tar(1, xs) = tar(1, xs) + 1
            End If
        Next
    Next
    
    Dim xn As Long, xp As Long
    tar(2, 1) = "Количество новых клиентов"
    For xs = 2 To UBound(sor, 2)
        For ys = 2 To UBound(sor, 1)
            If Not IsEmpty(sor(ys, xs)) Then
                xn = 0
                For xp = xs - 1 To 2 Step -1
                    If Not IsEmpty(sor(ys, xp)) Then
                        xn = xp
                    End If
                Next
                If xn = 0 Then
                    If xs > 2 Then
                        tar(2, xs) = tar(2, xs) + 1
                    End If
                End If
            End If
        Next
    Next
    
    For xs = 2 To UBound(sor, 2) - 1
        tar(xs + 1, 1) = "Количество клиентов " & sor(1, xs)
    Next
    
    For xs = 2 To UBound(sor, 2)
        For ys = 2 To UBound(sor, 1)
            If Not IsEmpty(sor(ys, xs)) Then
                For xp = xs - 1 To 2 Step -1
                    If Not IsEmpty(sor(ys, xp)) Then
                        tar(xp + 1, xs) = tar(xp + 1, xs) + 1
                    End If
                Next
            End If
        Next
    Next
    
    rSource.Rows(2).Copy rTarget
    rTarget.Value = tar
End Sub

Option Explicit

Sub Когорт_активлист()
    Dim rSource As Range, rTarget As Range
    Set rSource = Range("A1").CurrentRegion
    Set rTarget = rSource.Cells(rSource.Rows.Count + 3, 1)
    
    Cogort rSource, rTarget
End Sub

Private Sub Cogort(rSource As Range, rTarget As Range)
    Dim sor As Variant, ys As Long, xs As Long
    sor = rSource.Value
    
    For ys = 2 To UBound(sor, 1)
        sor(ys, 1) = Empty
    Next
    
    Dim tar As Variant
    ReDim tar(1 To 2 + UBound(sor, 2) - 2, 1 To UBound(sor, 2))
    
    Set rTarget = rTarget.Resize(UBound(tar, 1), UBound(tar, 2))
    
    tar(1, 1) = "Всего клиентов"
    For ys = 2 To UBound(sor, 1)
        For xs = 2 To UBound(sor, 2)
            If Not IsEmpty(sor(ys, xs)) Then
                tar(1, xs) = tar(1, xs) + 1
            End If
        Next
    Next
    
    For xs = 2 To UBound(sor, 2) - 1
        tar(xs + 1, 1) = "Количество клиентов " & sor(1, xs)
    Next
    
    Dim xn As Long, xp As Long
    tar(2, 1) = "Количество новых клиентов"
    For xs = 2 To UBound(sor, 2)
        For ys = 2 To UBound(sor, 1)
            If Not IsEmpty(sor(ys, xs)) Then
                xn = 0
                For xp = xs - 1 To 2 Step -1
                    If Not IsEmpty(sor(ys, xp)) Then
                        xn = xp
                    End If
                Next
                If xn = 0 Then
                    If xs > 2 Then
                        tar(2, xs) = tar(2, xs) + 1
                    End If
                Else
                    tar(xn + 1, xs) = tar(xn + 1, xs) + 1
                End If
            End If
        Next
    Next
    
    
    rSource.Rows(2).Copy rTarget
    rTarget.Value = tar
End Sub

ub Копировать_лист()
    Dim shSource As Worksheet
    Set shSource = ActiveSheet
    If Not IsDate(shSource.Name) Then Exit Sub
    
    Dim wb As Workbook
    Set wb = shSource.Parent
    Dim shTarget As Worksheet, targetName As String
    targetName = Format(CDate(shSource.Name) + 1, "DD.MM.YYYY")
    
    On Error Resume Next
    Set shTarget = wb.Sheets(targetName)
    On Error GoTo 0
    If Not shTarget Is Nothing Then
        MsgBox "Лист уже есть." & vbCr & targetName, vbExclamation
        Exit Sub
    End If
    
    shSource.Copy After:=shSource
    Set shTarget = ActiveSheet
    shTarget.Name = targetName
    
    Dim sFormula As String
    sFormula = "='" & shSource.Name & "'!J27+I27"
    shTarget.Range("J27").Formula = sFormula
End Sub

=ЕСЛИ(D1<>"";ЕСЛИ(G2=0;F1;G2);G2)

=ИНДЕКС(F1:F30;МАКС((D2:D30<>"")*СТРОКА(D2:D30)))

=ВПР(ТЕКСТ(МАКС(ЕСЛИОШИБКА(ДАТАЗНАЧ(D2:D30);0));"ДД.ММ.ГГГГ");D:F;3;0)

=(ЦЕЛОЕ((B2-0,5)/2)+ABS(ЦЕЛОЕ((B2-0,5)/2)-2))/2*B2-2*(ЦЕЛОЕ((B2-0,5)/2)-2)*((ЦЕЛОЕ((B2-0,5)/2)-2)+1)*(ЗНАК((ЦЕЛОЕ((B2-0,5)/2)-2))+1)/2-1+2*(ЗНАК(-ABS(B2-6))+1)

Function ВЫВЕСТИДАННЫЕ(диаметры_и_высоты As Range) As String
    Dim arr As Variant
    arr = диаметры_и_высоты.Rows(1).Value
    Dim xa As Long, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For xa = 1 To UBound(arr, 2) Step 2
        If arr(1, xa) <> "" Then dic(arr(1, xa)) = Empty
    Next
    If dic.Count > 0 Then
        Dim brr As Variant
        brr = dic.Keys()
        Quicksort brr, 0, UBound(brr)
        
        ВЫВЕСТИДАННЫЕ = Join(brr, " - ")
    End If
End Function

Private Sub Quicksort(vArray As Variant, arrLbound As Long, arrUbound As Long)
'Sorts a one-dimensional VBA array from smallest to largest
'using a very fast quicksort algorithm variant.
Dim pivotVal As Variant
Dim vSwap    As Variant
Dim tmpLow   As Long
Dim tmpHi    As Long
 
tmpLow = arrLbound
tmpHi = arrUbound
pivotVal = vArray((arrLbound + arrUbound) \ 2)
 
While (tmpLow <= tmpHi) 'divide
   While (vArray(tmpLow) < pivotVal And tmpLow < arrUbound)
      tmpLow = tmpLow + 1
   Wend
  
   While (pivotVal < vArray(tmpHi) And tmpHi > arrLbound)
      tmpHi = tmpHi - 1
   Wend
 
   If (tmpLow <= tmpHi) Then
      vSwap = vArray(tmpLow)
      vArray(tmpLow) = vArray(tmpHi)
      vArray(tmpHi) = vSwap
      tmpLow = tmpLow + 1
      tmpHi = tmpHi - 1
   End If
Wend
 
  If (arrLbound < tmpHi) Then Quicksort vArray, arrLbound, tmpHi 'conquer
  If (tmpLow < arrUbound) Then Quicksort vArray, tmpLow, arrUbound 'conquer
End Sub