在VBScript中退出應用程序後，Excel進程仍在運行

Question

我有一個每天運行的VBScript來整理每天晚上上傳到共享驅動器的Excel文件。我遇到的問題是，即使在我退出Excel應用程序後，Excel進程仍在任務管理器中運行。我想確保每次運行VBScript時Excel都會被完全終止。有趣的是，我也嘗試從宏中的VBA中關閉Excel，它仍然不終止進程，但是如果我直接運行宏（通過打開Excel並從那裏運行宏），進程會終止正常。

我使用的代碼如下：

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 

編輯：

下面是在Excel宏 「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

嘗試了這一點，看看它有助於：

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 

Answer 2

試試看DD以下爲「SortData」的開頭或打開工作簿後的地方：

If ActiveWorkbook.Close then 
    Exit Sub 
End If