Option Explicit

Public Sub New_Commandbar()
Dim Cbr As CommandBar
Dim Ctr As CommandBarControl
On Error Resume Next
Application.CommandBars("PivotTable Context Menu").Delete
Application.CommandBars.Add Name:="PivotTable Context Menu", Position:=msoBarPopup, Temporary:=True
For Each Ctr In Application.CommandBars("PivotTable Context Menu").Controls
    With Application.CommandBars("PivotTable Context Menu").Controls.Add(Ctr.Type, Ctr.ID, Ctr.Parameter, , 1)
        If (Ctr.Caption <> "Показать список поле&й") Or (Ctr.Caption <> "&Параметры полей значений...") Then
        
        Else
            Ctr.Delete
        End If
    End With
Next
End Sub

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  Cancel = True
  New_Commandbar
  Application.CommandBars("PivotTable Context Menu").Show
End Sub

'поиск ошибок по данным столбца M
    lLastRow = lLastRow - 1
    Dim J As Long
    J = 1
    Dim sTmp As String
    For i = 3 To lLastRow
        'значение ячейки
        sTmp = Range("M" & i).Value
        'возможные начальные и конечные пробелы
        sTmp = Trim(sTmp)
        'меняем значения ячейки только при указанных трех условиях
        If (sTmp Like "usi*") Or (sTmp Like "Usi*") Then
            Range("M" & i).Value = "USING"
        ElseIf (sTmp Like "proc*") Or (sTmp Like "Proc*") Then
            Range("M" & i).Value = "PROCESS"
        ElseIf (sTmp Like "pen*") Or (sTmp Like "Pen*") Then
            Range("M" & i).Value = "PENALTY"
        Else
            'если содержимое отличается от указанных выше
            'копируем на лист ошибок строку и добавляем в столбец U фразу
            Range("A" & i).EntireRow.Copy currentWB.Worksheets("Errors").Range("A" & J)
            currentWB.Worksheets("Errors").Range("U" & J).Value = "Not USING, PROCESS, PENALTY"
            J = J + 1
        End If
    Next i

Dim accessProp As Boolean
accessProp = False
...
'открытие книги
Workbooks.Open tmpFileName, UpdateLinks:=0

'проверка на совместный доступ
If ActiveWorkbook.MultiUserEditing Then
            ActiveWorkbook.ExclusiveAccess
            accessProp = True
End If
Set tmpWB = ActiveWorkbook
....
....
....

'закрытие книги
If (accessProp = True) Then
            'tmpWB.MultiUserEditing <- ошибка INVALID USE OF PROPERTY
            'accessProp = False
End If
tmpWB.Close savechanges:=False

Run-time error '-2147417848 (80010108)':
Automation error - Вызванный объект был отключен от клиентов

    Dim outputWorkbook As Workbook
    Set outputWorkbook = Workbooks.Add
    Dim dt As String
    Dim outFilename As String
    dt = Format(CStr(Now), "ddmmyyyyhhmmss")
    outFilename = ThisWorkbook.Path & "\REPORT_" & dt
    outputWorkbook.SaveAs outFilename
    'currentWB.Worksheets("Errors").Copy outputWorkbook.Worksheets(1)
    'currentWB.Worksheets("REPORT").Copy outputWorkbook.Worksheets(2) '<-Ошибка тут
    'currentWB.Worksheets("Summary").Copy outputWorkbook.Worksheets(3)
    currentWB.Worksheets("Errors").Copy before:=outputWorkbook.Sheets(1)
    currentWB.Worksheets("REPORT").Copy before:=outputWorkbook.Sheets(1) '<-Ошибка тут
    currentWB.Worksheets("Summary").Copy before:=outputWorkbook.Sheets(1)
        
    outputWorkbook.Close savechanges:=True

'создание таблицы Summary
ActiveSheet.ListObjects.Add(xlSrcRange, Range(Cells(2, 1), Cells(getLastRow("A"), getLastColumn("A", 2))), , xlGuess, xlNo).Name = "Summary"
ActiveSheet.ListObjects("Summary").TableStyle = "TableStyleLight14"
'обновить все
Refresh 

'функция обновления сводной таблицы
Sub Refresh()
    Dim nName As Name
    Dim x As PivotCache
 
    'http://www.planetaexcel.ru/forum/?PAGE_NAME=read&FID=8&TID=34084
 
    For Each nName In ThisWorkbook.Names
      If nName.Name Like "Svod" Then nName.Delete 'удаляем имя для диапазона сводной (прошлое)
    Next nName
    'создаём новое имя с тем же названием для нового диапазона
    Sheets("Data").Range("A5").CurrentRegion.Name = "Svod"
         
    'Лист на котором сводная
    ThisWorkbook.Sheets("REPORT").Activate
    For Each x In Application.ActiveWorkbook.PivotCaches
        x.MissingItemsLimit = xlMissingItemsNone
        x.Refresh  'ОШИБКА ТУТ
    Next
End Sub

'добавляю новый лист в текущую книгу
currentWB.Sheets.Add.Name = "Data"
'копирую
currentWB.Worksheets("OLD_Data").Copy Worksheets("Data")

Set rng = ActiveSheet.Range("Z3:Z" & getLastRow("Z"))
rng.NumberFormat = "@"

Worksheets("Summary").Activate

Dim countRows As Long
Dim accounts As String
Dim rTable As Range
Dim rRow As Range
Dim j As Long
    
'массив для сохранения номеров фильтрованных строк
Dim numArray() As Long
    
For i = 0 To countRowsFromWS_Input - 2  
   'i-ое значение в критерий из массива
        ActiveSheet.ListObjects("sumTable").Range.AutoFilter Field:=19, Criteria1:=valuesArray(i)
        countRows = CountVisibleRows(1)
        ReDim numArray(countRows)
        j = 0
        
        'сбор номеров фильтрованных строк
        Set rTable = ActiveSheet.UsedRange
        For Each rRow In rTable.SpecialCells(xlCellTypeVisible).Rows
            numArray(j) = rRow.Row
            j = j + 1
        Next rRow
        
        'первый элемент пропуск - шапка   
        For j = countRows To 1 Step -1
            If (Range("B" & numArray(j)).Value = Range("B" & numArray(j - 1))) Then
                        Range("B" & numArray(j)).EntireRow.Delete (xlUp)
                        Range("B" & numArray(j - 1)).EntireRow.Delete (xlUp)
                
            End If
        Next j
   'оставшиеся строки копировать
Next i

Dim visibleCells As Range
Dim visibleCellsCount As Long
Dim j As Long

For i = 2 To countSizeWorksheet1
        account = valuesArray(i)
        ActiveSheet.ListObjects("Summary").Range.AutoFilter Field:=10, Criteria1:=account
        Set visibleCells = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible)
        visibleCellsCount = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Count
        j=1
        while (j<visibleCellsCount) 'как узнать количество отфильтрованных строк ?
            '... манипуляции 
            'if (условие) then удаление строки текущей и одной из следующих
next i

...
    Dim startLT As Double
    Dim endLT As Double
    startLT = ThisWorkbook.Worksheets(1).Range("D7").Value
    endLT = ThisWorkbook.Worksheets(1).Range("E7").Value
   
    'преобразую в формат пользовательский hh.hh в формат hh:mm:ss  (т.е. 2.5 = 2:30:00)
    Dim startTime As Date
    Dim endTime As Date
    startTime = CDate(startLT / 24)
    endTime = CDate(endLT / 24)

    Dim CN As New ADODB.connection         
    CN.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                            "Data Source=" & fName & _
                            ";Extended Properties=""Excel 12.0;HDR=YES"""
    CN.Open
    
    'листы для запросов
    Dim names
    names = Array("000", "001", "010", "011", "100", "101", "110")
    Dim i As Long
    Dim sSQL As String
    Dim tableName As String
    Dim sqlTime As String
    sqlTime = "SQLTime"            'заголовок столбца
    For i = 1 To UBound(names, 1)
        
        ActiveWorkbook.Worksheets("Summary").Activate
        
        'очистка для удобства теста
        ActiveSheet.Cells.Select
        Selection.Delete xlUp
        Selection.Clear
        
        Set RS = Nothing
        Set RS = CreateObject("ADODB.Recordset")
        
        tableName = "[" & CStr(names(i)) & "$]"
        sSQL = "SELECT * FROM " & tableName & " WHERE " & sqlTime & " BETWEEN '" & startTime & "' AND '" & endTime & "'"
       
        'в окне locals значения 
        'sSQL ="SELECT * FROM [001$] WHERE SQLTime BETWEEN '3:00:00' AND '8:00:00'"
        'startTime=#3:00:00#        '<- тип Date
        'endtime=#8:00:00#          '<- тип Date


        MsgBox sSQL
        RS.Open sSQL, CN              ' <<<< РУГАЕТСЯ НА ЭТУ СТРОКУ
        ActiveWorkbook.Worksheets("Summary").Activate
        Range("A1").CopyFromRecordset RS
    Next i
...