Option Explicit
   Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
     (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
   Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
     (ByVal hwnd As Long, ByVal lpString As String, _
     ByVal aint As Long) As Long
   Declare Function GetWindow Lib "user32" _
     (ByVal hwnd As Long, ByVal wCmd As Long) As Long
   Declare Function EnumWindows Lib "user32" _
     (ByVal wndenmprc As Long, ByVal lParam As Long) As Long
   Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
     (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
     lParam As Any) As Long

   Private Const WM_CLOSE = &H10
   Private Const GW_HWNDFIRST = 0
   Private Const GW_HWNDLAST = 1
   Private Const GW_HWNDNEXT = 2
   Private Const GW_HWNDPREV = 3
   Private Const GW_OWNER = 4
   Private Const GW_CHILD = 5
   Private Const GW_MAX = 5

   Private mstrTarget As String
   Private mblnSuccess As Boolean


Public Function blnFindWindow(strApplicationTitle As String) As Boolean

   Dim hWndTmp As Long
   Dim nRet As Integer
   Dim TitleTmp As String
   Dim TitlePart As String
   Dim MyWholeTitle As String
   Dim mCounter As Long
   Dim hWndOver As Integer
   Dim sClassName As String * 100

   blnFindWindow = False

   TitlePart = UCase$(strApplicationTitle)

   'loop through all the open windows
   hWndTmp = FindWindow(0&, 0&)

   Do Until hWndTmp = 0

      TitleTmp = Space$(256)
      nRet = GetWindowText(hWndTmp, TitleTmp, Len(TitleTmp))

      If nRet Then
         'retrieve window title
         TitleTmp = UCase$(VBA.Left$(TitleTmp, nRet))
         'compare window title & strApplicationTitle
         If InStr(TitleTmp, TitlePart) Then
            blnFindWindow = True
            Exit Do
         End If
      End If

      hWndTmp = GetWindow(hWndTmp, GW_HWNDNEXT)
      mCounter = mCounter + 1

   Loop

   End Function


Public Function blnCloseWindow(strApplicationTitle As String) As Boolean

   ' retrieve Windows list of tasks.
   mblnSuccess = False
   mstrTarget = strApplicationTitle
   EnumWindows AddressOf EnumCallback, 0
   blnCloseWindow = mblnSuccess

End Function


Public Function EnumCallback(ByVal app_hWnd As Long, _
  ByVal param As Long) As Long

   Dim buf As String * 256
   Dim title As String
   Dim length As Long

   ' Checks a returned task to determine if App should be closed

   ' get window's title.
   length = GetWindowText(app_hWnd, buf, Len(buf))
   title = Left$(buf, length)

   ' determine if target window.
   If InStr(UCase(title), UCase(mstrTarget)) <> 0 Then
      ' Kill window.
      SendMessage app_hWnd, WM_CLOSE, 0, 0
      mblnSuccess = True
   End If

   ' continue searching.
   EnumCallback = 1

End Function
'------------------------ Сама подпрограмма для закрытия -------------------
Sub main()
'Это функция для закрытия окна с фалом
  If blnFindWindow("название файла без разширения") Then
       If Not blnCloseWindow("название файла без разширения") Then
           MsgBox "Problems encountered closing Window", _
             vbInformation, "API Call"
           Exit Sub
       End If
   End If

End Sub

Sub fProba()
' On Error Resume Next

objPPA = Application

GetObject(, objPPA).Quit
GetObject(, "Microsoft PowerPoint.Application").Quit
End Sub

Sub fClouse()
    On Error Resume Next
    GetObject(, "PowerPoint.Application").Quit
    GetObject(, "Word.Application").Quit
    GetObject(, "Visio.Application").Quit
End Sub

Function fOpenFile(sFPath As String) As Boolean
    On Error Resume Next
    fOpenFile = ShellExecute(0&, "Open", sFPath, _
                        vbNullString, vbNullString, 1&) > 32
End Function

Пробовал:
Dim objWork As Object  
 On Error Resume Next
     Set objWork = GetObject(, "PowerPoint.Application")
    objWork .Quit

    Do While ActiveSheet.PivotTables("СводнаяТаблица1").VisibleFields.Count > 0
     ActiveSheet.PivotTables("СводнаяТаблица1").VisibleFields(1).Orientation = xlHidden
    Loop