=ЕСЛИ(B2="Exit";0;ИНДЕКС($D$2:$D$14482;ПОИСКПОЗ("Entry";$B$2:$B$14482;0)))
=ЕСЛИ(B2="Entry";0;ИНДЕКС(D2:D14482;ПОИСКПОЗ("Entry";$B$2:$B$14482;0)))

Sub test()
 
Set spis = ThisWorkbook.Worksheets(1)
Set otch = ThisWorkbook.Worksheets(2)
 
 
spis.Cells.Replace " (*)", ""
i = 4
 
On Error Resume Next Do While otch.Cells(i, 2) <> ""
    j = 3
    Do While otch.Cells(3, j) <> "ÑóììГ* Г§Г* Г*åäåëþ"
        r = ""
        
        r = spis.Range(spis.Cells(8, 1), spis.Cells(65536, 1)).Find(otch.Cells(3, j)).Row
        If r <> "" Then
            r2 = r
            If spis.Cells(r2 + 1, 1) Like "" And spis.Cells(r2 + 1, 4) <> "" Then spis.Cells(r2 + 1, 1) = spis.Cells(r2, 1)
            
            spis.Range("F" & r2).FormulaR1C1 = "=RC[-1]-RC[-2]"
            
            Do While spis.Cells(r2 + 1, 1) Like otch.Cells(3, j)
                r2 = r2 + 1
                If spis.Cells(r2 + 1, 1) Like "" And spis.Cells(r2 + 1, 4) <> "" Then spis.Cells(r2 + 1, 1) = spis.Cells(r2, 1)
                spis.Range("F" & r2).FormulaR1C1 = "=RC[-1]-RC[-2]"
            Loop
            sotr = ""
            sotr = spis.Range(spis.Cells(r - 1, 2), spis.Cells(r2, 2)).Find(what:=otch.Cells(i, 2)).Row
            Tot = sotr
            If sotr <> "" Then
                If spis.Cells(sotr + 1, 2) Like "" And spis.Cells(sotr + 1, 4) <> "" Then spis.Cells(sotr + 1, 2) = spis.Cells(sotr, 2)
                Do While spis.Cells(sotr + 1, 2) Like otch.Cells(i, 2)
                    sotr = sotr + 1
                    If spis.Cells(sotr + 1, 2) Like "" And spis.Cells(sotr + 1, 4) <> "" Then spis.Cells(sotr + 1, 2) = spis.Cells(sotr, 2)
                Loop
                spis.Range("G" & Tot).FormulaR1C1 = "=SUM(RC[-1]:R[" & sotr - Tot & "]C[-1])"
            End If
            otch.Cells(i, j) = spis.Cells(Tot, 7).Value
            otch.Range(otch.Cells(i, j), otch.Cells(i, j)).NumberFormat = "hh:mm"
            spis.Cells(Tot, 7) = ""
        End If
    j = j + 1
    Loop
    otch.Range(otch.Cells(i, j), otch.Cells(i, j)).NumberFormat = "d hh:mm"
    otch.Range(otch.Cells(i, j), otch.Cells(i, j)).FormulaR1C1 = "=SUM(RC[-1]:RC[-" & j - 3 & "])"
    
    s = Split(otch.Cells(i, j).Text, " ")
    s2 = Split(s(1), ":")
    
    otch.Range(otch.Cells(i, j), otch.Cells(i, j)).NumberFormat = "@"
    Tot = CStr(s(0) * 24 + s2(0)) & ":" & s2(1)
    otch.Range(otch.Cells(i, j), otch.Cells(i, j)).NumberFormat = "@"
    otch.Cells(i, j) = Tot
    
i = i + 1
Loop
 
spis.Columns(6).Delete
On Error GoTo 0
 
End Sub

Private Function sOLAP_FilterByItemList(ByVal pvf As PivotField, _
   ByVal vItemsToBeVisible As Variant, _
   ByVal sItemPattern As String) As String
'--filters an OLAP pivotTable to display a list of items,
'    where some of the items might not exist
'--works by testing whether each pivotitem exists, then building an
'    array of existing items to be used with the VisibleItemsList property
'--requires Excel 2007 or later
'--Input Parameters:
'  pvf                pivotfield object to be filtered
'  vItemsToBeVisible  array of strings representing items to be visible
'  sItemPattern       string that has MDX pattern of pivotItem reference
'                     where the text "ThisItem" will be replaced by each
'                     item in vItemsToBeVisible to make pivotItem references.
'                     e.g.: "[tblSales].[product_name].&[ThisItem]"
    
 Dim lFilterItemCount As Long, lNdx As Long
 Dim vFilterArray As Variant
 Dim vSaveVisibleItemsList As Variant
 Dim sReturnMsg As String, sPivotItemName As String
  
 '--store existing visible items
 vSaveVisibleItemsList = pvf.VisibleItemsList
  
 If Not (IsArray(vItemsToBeVisible)) Then _
   vItemsToBeVisible = Array(vItemsToBeVisible)
 ReDim vFilterArray(1 To _
   UBound(vItemsToBeVisible) - LBound(vItemsToBeVisible) + 1)
 pvf.Parent.ManualUpdate = True
  
 '--check if pivotitem exists then build array of items that exist
 For lNdx = LBound(vItemsToBeVisible) To UBound(vItemsToBeVisible)
   '--create MDX format pivotItem reference by substituting item into pattern
   sPivotItemName = Replace(sItemPattern, "ThisItem", vItemsToBeVisible(lNdx))
    
   '--attempt to make specified item the only visible item
   On Error Resume Next
   pvf.VisibleItemsList = Array(sPivotItemName)
   On Error GoTo 0
    
   '--if item doesn't exist in field, this will be false
   If LCase$(sPivotItemName) = LCase$(pvf.VisibleItemsList(1)) Then
      lFilterItemCount = lFilterItemCount + 1
      vFilterArray(lFilterItemCount) = sPivotItemName
   End If
 Next lNdx
  
 '--if at least one existing item found, filter pivot using array
 If lFilterItemCount > 0 Then
   ReDim Preserve vFilterArray(1 To lFilterItemCount)
   pvf.VisibleItemsList = vFilterArray
 Else
   sReturnMsg = "No matching items found."
   pvf.VisibleItemsList = vSaveVisibleItemsList
 End If
 pvf.Parent.ManualUpdate = False
 sOLAP_FilterByItemList = sReturnMsg
End Function
Sub CallingExample()
'--пример, показывающий вызов функции
 Dim pvt As PivotTable
 Dim sErrMsg As String, sTemplate As String
 Dim vItemsToBeVisible As Variant
 Dim lLastRow As Long
 Dim sItemPattern As String
 On Error GoTo ErrProc
 With Application
   .EnableCancelKey = xlErrorHandler
   .ScreenUpdating = False
   .DisplayStatusBar = False
   .EnableEvents = False
 End With
    
 '--используем элементы фильтра из таблицы рабочих таблиц
 With Sheets("Фильтры")
   lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    
   vItemsToBeVisible = Application.Transpose( _
      .Range("A2:A" & lLastRow).Value)
 End With
 Set pvt = ActiveSheet.PivotTables("Сводная таблица1")
 '--вызываем функцию
 sErrMsg = sOLAP_FilterByItemList( _
   pvf:=pvt.PivotFields("[Сеть].[Код].[Код]"), _
   vItemsToBeVisible:=vItemsToBeVisible, _
   sItemPattern:="[Сеть].[Код].[Код]")
  
ExitProc:
 On Error Resume Next
 With Application
   .EnableEvents = True
   .DisplayStatusBar = True
   .ScreenUpdating = True
 End With
 If Len(sErrMsg) > 0 Then MsgBox sErrMsg
 Exit Sub
  
ErrProc:
 sErrMsg = Err.Number & " - " & Err.Description
 Resume ExitProc
End Sub

Dim Head_TT As Integer
    Dim k As Integer
    For k = 1 To ActiveSheet.PivotTables("Сводная таблица1").CubeFields.Count
    If ActiveSheet.PivotTables("Сводная таблица1").CubeFields(k).Value = "[Сеть].[Магазины]" Then
    Head_TT = ActiveSheet.PivotTables("Сводная таблица1").CubeFields(k).Position
    End If
    Next

Public Sub SplitToFiles()
' MACRO SplitToFiles
' Last update: 2012-03-04
' Author: mtone
' Version 1.1
' Description:
' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above
'
' Note: Values in the column should be unique or sorted.
'
' The following cells are ignored when delimiting sections:
' - blank cells, or containing spaces only
' - same value repeated
' - cells containing "total"
'
' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name.
Dim osh As Worksheet ' Original sheet
Dim iRow As Long ' Cursors
Dim iCol As Long
Dim iFirstRow As Long ' Constant
Dim iTotalRows As Long ' Constant
Dim iStartRow As Long ' Section delimiters
Dim iStopRow As Long
Dim sSectionName As String ' Section name (and filename)
Dim rCell As Range ' current cell
Dim owb As Workbook ' Original workbook
Dim sFilePath As String ' Constant
Dim iCount As Integer ' # of documents created
iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1)
iFirstRow = iRow
Set osh = Application.ActiveSheet
Set owb = Application.ActiveWorkbook
iTotalRows = osh.UsedRange.Rows.Count
sFilePath = Application.ActiveWorkbook.Path
If Dir(sFilePath + "\Split", vbDirectory) = "" Then
    MkDir sFilePath + "\Split"
End If
'Turn Off Screen Updating  Events
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do
    ' Get cell at cursor
    Set rCell = osh.Cells(iRow, iCol)
    sCell = Replace(rCell.Text, " ", "")
    If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
        ' Skip condition met
    Else
        ' Found new section
        If iStartRow = 0 Then
            ' StartRow delimiter not set, meaning beginning a new section
            sSectionName = rCell.Text
            iStartRow = iRow
        Else
            ' StartRow delimiter set, meaning we reached the end of a section
            iStopRow = iRow - 1
            ' Pass variables to a separate sub to create and save the new worksheet
            CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
            iCount = iCount + 1
            ' Reset section delimiters
            iStartRow = 0
            iStopRow = 0
            ' Ready to continue loop
            iRow = iRow - 1
        End If
    End If
    ' Continue until last row is reached
    If iRow < iTotalRows Then
            iRow = iRow + 1
    Else
        ' Finished. Save the last section
        iStopRow = iRow
        CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
        iCount = iCount + 1
        ' Exit
        Exit Do
    End If
Loop
'Turn On Screen Updating  Events
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
MsgBox Str(iCount) + " documents saved in " + sFilePath

End Sub
Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)
Dim rngRange As Range
Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
rngRange.Select
rngRange.Delete
End Sub

Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
     Dim ash As Worksheet ' Copied sheet
     Dim awb As Workbook ' New workbook
     ' Copy book
     osh.Copy
     Set ash = Application.ActiveSheet
     ' Delete Rows after section
     If iTotalRows > iStopRow Then
         DeleteRows ash, iStopRow + 1, iTotalRows
     End If
     ' Delete Rows before section
     If iStartRow > iFirstRow Then
         DeleteRows ash, iFirstRow, iStartRow - 1
     End If
     ' Select left-topmost cell
     ash.Cells(1, 1).Select
     ' Clean up a few characters to prevent invalid filename
     sSectionName = Replace(sSectionName, "/", " ")
     sSectionName = Replace(sSectionName, "\", " ")
     sSectionName = Replace(sSectionName, ":", " ")
     sSectionName = Replace(sSectionName, "=", " ")
     sSectionName = Replace(sSectionName, "*", " ")
     sSectionName = Replace(sSectionName, ".", " ")
     sSectionName = Replace(sSectionName, "?", " ")
     ' Save in same format as original workbook
     ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat
     ' Close
     Set awb = ash.Parent
     awb.Close SaveChanges:=False
End Sub

Public Sub SplitToFiles()
' MACRO SplitToFiles
' Last update: 2012-03-04
' Author: mtone
' Version 1.1
' Description:
' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above
'
' Note: Values in the column should be unique or sorted.
'
' The following cells are ignored when delimiting sections:
' - blank cells, or containing spaces only
' - same value repeated
' - cells containing "total"
'
' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name.
Dim osh As Worksheet ' Original sheet
Dim iRow As Long ' Cursors
Dim iCol As Long
Dim iFirstRow As Long ' Constant
Dim iTotalRows As Long ' Constant
Dim iStartRow As Long ' Section delimiters
Dim iStopRow As Long
Dim sSectionName As String ' Section name (and filename)
Dim rCell As Range ' current cell
Dim owb As Workbook ' Original workbook
Dim sFilePath As String ' Constant
Dim iCount As Integer ' # of documents created
iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1)
iFirstRow = iRow
Set osh = Application.ActiveSheet
Set owb = Application.ActiveWorkbook
iTotalRows = osh.UsedRange.Rows.Count
sFilePath = Application.ActiveWorkbook.Path
If Dir(sFilePath + "\Split", vbDirectory) = "" Then
    MkDir sFilePath + "\Split"
End If
'Turn Off Screen Updating  Events
Application.EnableEvents = False
Application.ScreenUpdating = False
Do
    ' Get cell at cursor
    Set rCell = osh.Cells(iRow, iCol)
    sCell = Replace(rCell.Text, " ", "")
    If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
        ' Skip condition met
    Else
        ' Found new section
        If iStartRow = 0 Then
            ' StartRow delimiter not set, meaning beginning a new section
            sSectionName = rCell.Text
            iStartRow = iRow
        Else
            ' StartRow delimiter set, meaning we reached the end of a section
            iStopRow = iRow - 1
            ' Pass variables to a separate sub to create and save the new worksheet
            CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
            iCount = iCount + 1
            ' Reset section delimiters
            iStartRow = 0
            iStopRow = 0
            ' Ready to continue loop
            iRow = iRow - 1
        End If
    End If
    ' Continue until last row is reached
    If iRow < iTotalRows Then
            iRow = iRow + 1
    Else
        ' Finished. Save the last section
        iStopRow = iRow
        CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
        iCount = iCount + 1
        ' Exit
        Exit Do
    End If
Loop
'Turn On Screen Updating  Events
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox Str(iCount) + " documents saved in " + sFilePath

End Sub
Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)
Dim rngRange As Range
Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
rngRange.Select
rngRange.Delete
End Sub

Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
     Dim ash As Worksheet ' Copied sheet
     Dim awb As Workbook ' New workbook
     ' Copy book
     osh.Copy
     Set ash = Application.ActiveSheet
     ' Delete Rows after section
     If iTotalRows > iStopRow Then
         DeleteRows ash, iStopRow + 1, iTotalRows
     End If
     ' Delete Rows before section
     If iStartRow > iFirstRow Then
         DeleteRows ash, iFirstRow, iStartRow - 1
     End If
     ' Select left-topmost cell
     ash.Cells(1, 1).Select
     ' Clean up a few characters to prevent invalid filename
     sSectionName = Replace(sSectionName, "/", " ")
     sSectionName = Replace(sSectionName, "\", " ")
     sSectionName = Replace(sSectionName, ":", " ")
     sSectionName = Replace(sSectionName, "=", " ")
     sSectionName = Replace(sSectionName, "*", " ")
     sSectionName = Replace(sSectionName, ".", " ")
     sSectionName = Replace(sSectionName, "?", " ")
     ' Save in same format as original workbook
     ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat
     ' Close
     Set awb = ash.Parent
     awb.Close SaveChanges:=False
End Sub