Private Sub Command1_Click() 'BOM处理
Dir1.Path = "D:\数据"
Dim s As Single
Dim n As Integer
Dim ss As String
Dim xlApp As Excel.Application
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
For ii = 1 To Dir1.ListCount
File1.Path = Dir1.List(ii - 1)
Set xlBook = xlApp.Workbooks.Open(File1.Path & "\" & File1.List(0)) '打开已经存在的EXCEL工件簿文件
Set xlSheet = xlBook.Sheets(1) '设置活动工作表
With xlBook.Sheets(1)
Range("D1").Select
Selection.Cut Destination:=Range("O4")
Range("F1").Select
Selection.Cut Destination:=Range("P4")
Rows("1:3").Select
Selection.Delete Shift:=xlUp
Range("A1:N1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$N$97").AutoFilter Field:=10, Criteria1:=Array( _
"插件"), Operator:=xlFilterValues
If [a65536].End(xlUp).Row > 1 Then '是否含插件
ActiveSheet.Range("$A$1:$N$180").AutoFilter Field:=10
ActiveSheet.Range("$A$1:$N$97").AutoFilter Field:=14, Criteria1:=Array( _
"PCB", "PCB印刷电路板", "印刷电路板", "印制电路板"), Operator:=xlFilterValues
Range("D1:D600,F1:F600").Select
Selection.Copy
Range("Q1").Select
ActiveSheet.Paste
ActiveSheet.Range("$A$1:$N$180").AutoFilter Field:=14
Range("Q1:R1").Select
Selection.Delete Shift:=xlUp
ActiveSheet.Range("$A$1:$N$180").AutoFilter Field:=10, Criteria1:=Array( _
"贴片", ""), Operator:=xlFilterValues
Rows("2:600").Select
Selection.Delete Shift:=xlUp
ActiveSheet.Range("$A$1:$N$14").AutoFilter Field:=10
Range("A1:C600,E1:E600,G1:G600,I1:M600").Select
Selection.Delete Shift:=xlToLeft
Columns("A:D").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("I1:L1").Select
Selection.Cut Destination:=Range("A1:D1")
Range("A1:D1").Select
Selection.AutoFill Destination:=Range("A1:D" & [e65536].End(xlUp).Row), Type:=xlFillCopy
Range("A1:H1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$N$97").AutoFilter Field:=2, Criteria1:=Array( _
"DS-21*", "DS-801*"), Operator:=xlFilterValues
If [g65536].End(xlUp) > 1 Then
ActiveSheet.Range("$A$1:$N$97").AutoFilter Field:=6, Criteria1:=Array( _
"*晶体*"), Operator:=xlFilterValues
If [g65536].End(xlUp) > 1 Then
For i = 2 To [g65536].End(xlUp).Row
Cells(i, 7) = Cells(i, 7) + 1
Next i
End If
ActiveSheet.Range("$A$1:$N$14").AutoFilter Field:=6
End If
ActiveSheet.Range("$A$1:$N$14").AutoFilter Field:=2
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Columns("G:G").Select
Range("G65536").Activate
ActiveCell.FormulaR1C1 = "=SUM(R[-65535]C:R[-1]C)"
s = Cells(65536, 7)
Call SJK_DZ
If s > 5 Then
rs.Source = "select * from 波峰焊BOM"
Else
rs.Source = "select * from 手焊BOM"
End If
rs.Open
For i = 1 To [e65536].End(xlUp).Row
rs.AddNew
For j = 1 To 8
rs.Fields(j) = Cells(i, j)
Next j
rs.Update
Next i
rs.Close
Else
ActiveSheet.Range("$A$1:$N$180").AutoFilter Field:=10
'n = [j65536].End(xlUp).Row
ActiveSheet.Range("$A$1:$N$97").AutoFilter Field:=10, Criteria1:=Array( _
"贴片"), Operator:=xlFilterValues
If [e65536].End(xlUp).Row > 1 Then
ss = "无字符串"
Else
ss = "纯测试"
End If
Call SJK_DZ
rs.Source = "select * from 纯测试无字符串"
rs.Open
rs.AddNew
rs.Fields(1) = Cells(1, 15)
rs.Fields(2) = Cells(1, 16)
rs.Fields(3) = ss
rs.Fields(4) = yhm
rs.Fields(5) = Now
rs.Update
rs.Close
End If
End With
Set xlSheet = Nothing '
xlBook.Close False
Set xlBook = Nothing '
Next ii
xlApp.Quit '
Set xlSheet = Nothing '
Set xlBook = Nothing '
Set xlApp = Nothing
cn.Close
Set rs = Nothing
Set cn = Nothing
MsgBox "导入成功！", , "提示信息"
End Sub

每次只能运行一次，第二次运行就会报错，我看了下，应该是因为进程里EXCEL.EXE没关掉的原因，怎么样才能彻底关掉啊？

同问

参考一下:
Dim xlapp As New 网页链接 '定义EXCEL对象
Dim xlbook As New 网页链接 '定义工作簿
Dim xlsheet As New 网页链接 '定义工作页
网页链接
网页链接 '关闭Excel
Set xlsheet = Nothing
Set xlbook = Nothing
Set xlapp = Nothing