在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