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宏＆＃34; SortData＆＃34;：

中运行的代码

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

尝试在打开此工作簿后将以下内容添加到“SortData”的开头或某处：

If ActiveWorkbook.Close then
    Exit Sub
End If

退出VBScript中的应用程序后Excel进程仍在运行

2 个答案: