Excel Process Still Running After Quitting Application in VBScript

Question

I have a VBScript that runs every day to sort out an Excel file that is uploaded every night to a shared drive. The issue I am running into is that even after I quit the Excel application, the Excel process is still running in the task manager. I want to make sure that Excel is terminated fully every time the VBScript is run.

Interestingly, I have also tried to close Excel from within the VBA in the macro and it still does not terminate the process but if I run the macro directly (by opening Excel and running the macro from there) the process does terminate properly.

The code I use is below:

Dim xlApp
Dim xlBook

Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open("\\File\Path\XL.xlsm", 0, True)

xlApp.Visible = False

xlApp.Run "SortData"

xlApp.ActiveWorkbook.Close false

xlApp.Quit

Set xlBook = Nothing
Set xlApp = Nothing

Edit:

Below is the code run in the Excel macro "SortData":

Public Sub SortData()

Dim Dummy As String
Dim MyPath As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim CheckFile As String
Dim Conc(100000) As String
Dim TheSelection As String
Dim TS As String
Dim TheDate As Date
Dim CheckDate As Date
Dim Newest As Date
Dim TheFile As Object
Dim i, n, j As Long
Dim Count As Long
Dim FNum As Long

Dim YearC(), Model(), SupNum(), SupName(), B5(), BPN(), MBPN(), PartName(), PackType(), QTY(), Rank(), PackWeight(), PartWeight(), Dunnage() As Variant
Dim Updated As Variant

Application.ScreenUpdating = False

MyPath = "\\File\Path\Sorted Parts Lists\"
TheDate = Date

FilesInPath = Dir(MyPath & "*.xl*")

If FilesInPath = "" Then GoTo Good

FNum = 0

Do While FilesInPath <> ""
    FNum = FNum + 1
    ReDim Preserve MyFiles(1 To FNum)
    MyFiles(FNum) = MyPath & FilesInPath
    FilesInPath = Dir()
Loop

Newest = "1/1/2000" 'Arbitrary start date
Set TheFile = CreateObject("Scripting.FileSystemObject")
For FNum = LBound(MyFiles) To UBound(MyFiles)
    CheckFile = MyFiles(FNum)
    Updated = TheFile.Getfile(CheckFile).DateLastModified
    If Updated > Newest Then 'Find the newest file in the folder
        Newest = Updated
    End If
Next FNum

If Newest >= TheDate - 7 Then GoTo TheEnd

Good:

Dim FilePath As String
FilePath = "\\File\Path\Parts List.xls"
Workbooks.Open Filename:=FilePath
ActiveWorkbook.Sheets(1).Select

ReDim YearC(100000)
ReDim Model(100000)
ReDim SupNum(100000)
ReDim SupName(100000)
ReDim B5(100000)
ReDim BPN(100000)
ReDim MBPN(100000)
ReDim PartName(100000)
ReDim PackType(100000)
ReDim QTY(100000)
ReDim Rank(100000)
ReDim PackWeight(100000)
ReDim PartWeight(100000)
ReDim Dunnage(100000)

Range("BB:HJ,Y:AZ,V:V,T:T,S:S,J:O,E:E").Select
Selection.Delete Shift:=xlToLeft

Range("K:K").Select
Selection.Delete Shift:=xlToLeft

i = 0
Count = 0
Range("D1").Select
TheSelection = Trim(Selection.Value)

Do While TheSelection <> ""
    Select Case TheSelection
        Case "AE", "HCM ST+ENG", "SIOO"
            GoTo NextRow
        Case Else
    End Select

    'Check for duplicates
    Dummy = TheSelection & Trim(Selection.Offset(0, 3).Value)
    For n = 0 To i
        If Conc(n) = Dummy Then
            GoTo NextRow
        End If
    Next n

    If i <> 0 Then Conc(i) = Dummy

    YearC(i) = Selection.Offset(0, -3).Value
    Model(i) = Selection.Offset(0, -2).Value
    SupNum(i) = Selection.Offset(0, -1).Value
    SupName(i) = Selection.Value
    B5(i) = Selection.Offset(0, 1).Value
    BPN(i) = Selection.Offset(0, 2).Value
    MBPN(i) = Selection.Offset(0, 3).Value
    PartName(i) = Selection.Offset(0, 4).Value
    PackType(i) = Selection.Offset(0, 5).Value
    QTY(i) = Selection.Offset(0, 6).Value
    Rank(i) = Selection.Offset(0, 7).Value
    PackWeight(i) = Selection.Offset(0, 8).Value
    PartWeight(i) = Selection.Offset(0, 9).Value
    Dunnage(i) = Selection.Offset(0, 10).Value

    i = i + 1
NextRow:

Count = Count + 1
Selection.Offset(1, 0).Select
TheSelection = Trim(Selection.Value)

If Count > 100000 Then
    Debug.Print "Escaped"
    Exit Sub
End If

Loop
ReDim Preserve YearC(i)
ReDim Preserve Model(i)
ReDim Preserve SupNum(i)
ReDim Preserve SupName(i)
ReDim Preserve B5(i)
ReDim Preserve BPN(i)
ReDim Preserve MBPN(i)
ReDim Preserve PartName(i)
ReDim Preserve PackType(i)
ReDim Preserve QTY(i)
ReDim Preserve Rank(i)
ReDim Preserve PackWeight(i)
ReDim Preserve PartWeight(i)
ReDim Preserve Dunnage(i)

'Range("A1:N" & Count).ClearContents

Sheets.Add After:=Worksheets(Worksheets.Count)
Sheets(Worksheets.Count).Name = "Sorted Data"
Sheets(Worksheets.Count).Select

ActiveSheet.Range("A1:A" & i).Value = WorksheetFunction.Transpose(YearC)
ActiveSheet.Range("B1:B" & i).Value = WorksheetFunction.Transpose(Model)
ActiveSheet.Range("C1:C" & i).Value = WorksheetFunction.Transpose(SupNum)
ActiveSheet.Range("D1:D" & i).Value = WorksheetFunction.Transpose(SupName)
ActiveSheet.Range("E1:E" & i).Value = WorksheetFunction.Transpose(B5)
ActiveSheet.Range("F1:F" & i).Value = WorksheetFunction.Transpose(BPN)
ActiveSheet.Range("G1:G" & i).Value = WorksheetFunction.Transpose(MBPN)
ActiveSheet.Range("H1:H" & i).Value = WorksheetFunction.Transpose(PartName)
ActiveSheet.Range("I1:I" & i).Value = WorksheetFunction.Transpose(PackType)
ActiveSheet.Range("J1:J" & i).Value = WorksheetFunction.Transpose(QTY)
ActiveSheet.Range("K1:K" & i).Value = WorksheetFunction.Transpose(Rank)
ActiveSheet.Range("L1:L" & i).Value = WorksheetFunction.Transpose(PackWeight)
ActiveSheet.Range("M1:M" & i).Value = WorksheetFunction.Transpose(PartWeight)
ActiveSheet.Range("N1:N" & i).Value = WorksheetFunction.Transpose(Dunnage)

ActiveSheet.Range("A1:N1").AutoFilter
ActiveSheet.Columns.AutoFit

TS = TheDate
j = Len(TS)
Dummy = ""
For i = 1 To j
    If Mid(TheDate, i, 1) = "/" Then
        Dummy = Dummy & "-"
    Else: Dummy = Dummy & Mid(TS, i, 1)
    End If
Next i

Application.DisplayAlerts = False
ActiveWorkbook.SaveAs MyPath & "Sorted DC Parts List " & Dummy & ".xlsx", 51
Application.DisplayAlerts = True
Application.ScreenUpdating = True

Exit Sub

TheEnd:

Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub

Answer 1

Try to add the following to the beginning of "SortData" or somewhere after opening this workbook:

If ActiveWorkbook.Close then
    Exit Sub
End If

Answer 2

Try this out and see if it helps:

Dim xlApp
Dim xlBook
'Create a shell
Dim WsShell 
Set WsShell = CreateObject("WScript.Shell")

Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open("\\File\Path\XL.xlsm", 0, True)

xlApp.Visible = False

xlApp.Run "SortData"

'Close the workbook, may want to save
xlApp.ActiveWorkbook.Close true

Set xlBook = Nothing
Set xlApp = Nothing
Set WsShell = Nothing
'Close the script
WScript.Quit