' --> Фрагмент кода для предотвращения преобразования текстовых данных в нетекстовые
      If VarType(a(i, j)) = vbString Then
        If Len(a(i, j)) > 0 Then a(i, j) = "'" & a(i, j)
      End If
      ' <-- Конец фрагмента

Sub SafeArrayToRange()
' ZVI:2018-04-02 https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&TID=103060
' Обработка массива для копирования на лист с предотвращением преобразования текстовых данных
  
  Dim ch As String
  Dim a(), i As Long, j As Long
  
  ' Скопировать данные в массив
  a() = Лист3.Range("A1:D20")
  
  ' Обработать данные массива
  For i = 1 To UBound(a)
    For j = 1 To UBound(a, 2)
      
      ' --> Здесь Ваша обработка элементов массива
      '     ...
      ' <-- Конец обработки
      
      ' --> Фрагмент кода для предотвращения преобразования текстовых данных в нетекстовые
      If VarType(a(i, j)) = vbString Then
        If Len(a(i, j)) > 0 Then
          ch = Mid$(a(i, j), 1, 1)
          If ch = "'" Then
            a(i, j) = "=""" & a(i, j) & """"
          ElseIf IsNumeric(a(i, j)) Or IsDate(a(i, j)) Then
            a(i, j) = "'" & a(i, j)
          End If
        End If
      End If
      ' <-- Конец фрагмента
      
    Next
  Next
  
  ' Скопировать данные массива на лист1 без преобразования текстовых данных
  With Лист1.Range("A1:D20")
    .NumberFormat = ""
    .Value = a()
  End With

End Sub

Sub Test()
  Dim App As Application
  Set App = New Application
  Stop      ' <-- Имитация зависания, в диспетчере задач 2 экземпляра объекта Excel
  App.Quit  ' <-- и даже после этой строки будут 2 экземпляра пока не выполнится End Sub
End Sub

Option Explicit

Private Sub Workbook_Open()
  Application.OnTime Now, Me.CodeName & ".Workbook_Open1"
End Sub

Private Sub Workbook_Open1()
  Me.Sheets("ОТЧЕТ").Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True, _
     AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, _
     AllowFiltering:=True, UserInterfaceOnly:=True
  meUpdate
End Sub

Sub meUpdate()
  '..........
  Dim kas As String ' <-- было пропущено
  Dim wbOpen As Workbook
  Dim xlApp As Application
  With Me.Sheets("ОТЧЕТ")
    '.......................
    kas = Me.Sheets("ДАНО").ListObjects("tblKassa").DataBodyRange(1).Value
    
    ' Проверить, что требуемый файл существует
    If Dir(kas) = "" Then
      MsgBox "Не найден файл:" & vbLf & kas, vbCritical, "Ошибка"
      Exit Sub
    End If
    
    Set xlApp = New Excel.Application ' <-- здесь было лишнее
    With xlApp
      .EnableEvents = False
      '.Visible = True
      Set wbOpen = .Workbooks.Open(kas, , True)
      With wbOpen.Sheets("КАССА")
        '.......................
      End With
    End With  ' <-- было пропущено
  End With    ' <-- было пропущено
  
  ' Закрыить книгу wbOpen и экземпляр приложения xlApp с освобождением памяти
  wbOpen.Close False
  Set wbOpen = Nothing
  xlApp.Quit
  Set xlApp = Nothing
  
End Sub

Private Sub Worksheet_Calculate()
  Static OldValue
  With Me.Range("D2")
    If .Value <> OldValue Then
      If .Value <> 7 Then
        MsgBox "D2 <> 7", vbCritical, "ОШИБКА!"
      End If
    End If
    OldValue = .Value
  End With
End Sub

Dim dt As Date

Sub DelMacro()
  ' Макрос очистки ячеек A1:B2 листа1
  Лист1.Range("A1:B2").ClearContents
End Sub

Sub Test1()
  ' Очистить A1:B2 через 5 секунд
  Application.OnTime Now + TimeValue("00:00:05"), "DelMacro"
End Sub

Sub Test2()
  ' Очистить A1:B2 сегодня в 14:20
  dt = TimeValue("14:20:00")
  Application.OnTime dt, "DelMacro"
End Sub

Sub Auto_Close()
  ' Если книга закрывается раньше запланированного времени очистки ячеек, то нужно отменить запланированное задание
  If dt <> 0 Then
    Application.OnTime dt, "DelMacro", Schedule:=False
  End If
End Sub

Sub FasterFaster()
  Dim Sh As Worksheet
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  With ActiveSheet
    For Each Sh In Worksheets
      Sh.DisplayAutomaticPageBreaks = False
      Sh.Activate
      ActiveWindow.View = xlNormalView
    Next
    .Activate
  End With
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub

Sub ShapesDelete()
  ActiveSheet.Rectangles.Delete
End Sub

Sub ShapesDelete1()
  Dim i As Long
  i = ActiveSheet.Rectangles.Count
  If i > 0 Then
    If MsgBox("Удалить объекты-прямоугольники, " & i & " шт ?", vbYesNo) = vbYes Then
      ActiveSheet.Rectangles.Delete
    End If
  Else
    MsgBox "Объектов прямоугольников на листе нет"
  End If
End Sub

If IsError(ActiveCell.Value) Then MsgBox "В ячейке - ошибка!"