【发布时间】：2018-08-01 15:59:07
【问题描述】：
在显示“sh.Range("A2").CopyFromRecordset rs2”的行上 我在众多计算机中只有一台计算机出现自动化错误（我不知道有多少，但至少有 10+） 查询只是一个基本的参数化查询，数据源在 SQL Server 中，我把它放在最后。
Private Sub export2()
If Not BasicInclude.DebugMode Then On Error GoTo Error_Handler Else On Error GoTo 0
Dim app As Object
Dim w As Object
Dim sh As Object
Dim iCols As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim c As Long
Dim d As Long
Dim e As Boolean
Dim s(4) As String
Dim v As Variant
Const xlCenter = -4108
Dim q As Variant
Dim qu As Long
Dim r As Variant
Dim t As Variant
Dim out() As Variant
Dim TidList As Variant
Dim rs() As ADODB.Recordset
Dim count As Long
Dim v2 As Variant
Dim counter As Long
Dim mem() As Variant
Dim DescGroup As Long
Dim ubrs As Long
Dim temp As New Collection
Dim TestItem As Variant
Dim f As ADODB.Field
Dim p As Object
Dim qry As QueryDef
Dim rs2 As DAO.Recordset
Set app = CreateObject("Excel.Application")
app.ScreenUpdating = False
app.Visible = False
'app.ScreenUpdating = True
'app.Visible = True
Set w = app.Workbooks.Add()
由于它不相关，因此将其截断
'Start'Resistance'Tester'Export'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set qry = dbLocal.QueryDefs("qryResistanceData")
qry.Parameters(0).Value = s(0)
qry.Parameters(1).Value = s(1)
qry.Parameters(2).Value = s(2)
qry.Parameters(3).Value = s(3)
qry.Parameters(4).Value = s(4)
Set rs2 = qry.OpenRecordset(dbOpenSnapshot)
On Error GoTo 0
With rs2
If .RecordCount <> 0 Then
Set sh = w.Sheets(1)
sh.Name = TestItem(0) & " " & TestItem(6) & " " & TestItem(5)
'Build our Header
For iCols = 0 To rs2.Fields.count - 1
sh.Cells(1, iCols + 1).numberformat = "@"
sh.Cells(1, iCols + 1).Value = rs2.Fields(iCols).Name
Next
With sh.Range(sh.Cells(1, 1), sh.Cells(1, rs2.Fields.count))
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 1
.HorizontalAlignment = xlCenter
End With
sh.Range(sh.Cells(2, 1), sh.Cells(rs2.RecordCount + 1, 3)).numberformat = "@"
sh.Range(sh.Cells(2, 4), sh.Cells(rs2.RecordCount + 1, rs2.Fields.count)).numberformat = "0.0000"
'Copy the data from our query into Excel
sh.Range("A2").CopyFromRecordset rs2
sh.Range("A1").Select
'Return to the top of the page
sh.Range(sh.Cells(1, 1), sh.Cells(rs2.RecordCount, rs2.Fields.count)).Columns.AutoFit
'Resize our Columns based on the headings
app.activewindow.splitcolumn = 0
app.activewindow.splitrow = 1
app.activewindow.freezepanes = True
w.Sheets.Add
End If
End With
还有更多与问题无关的代码
For Each sh In w.Sheets
If sh.Name Like "Sheet*" And w.Sheets.count > 1 Then
w.Sheets(sh.Name).Delete
End If
Next
If counter = temp.count Then
w.Close False
app.Quit
MsgBox "No Data Found."
Else
app.ScreenUpdating = True
app.Visible = True
End If
Else
MsgBox "Please choose a part and test."
End If
Error_Exit:
Set app = Nothing
Exit Sub
Error_Handler:
If Not app Is Nothing Then
If Not w Is Nothing Then
w.Close False
End If
app.Quit
End If
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: " & Err.Source & vbCrLf & _
"Error Description: " & Err.Description _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Exit
End Sub
阻力查询
PARAMETERS tn Text ( 255 ), sns Long, sne Long, ds DateTime, de DateTime;
SELECT
PartListTruncated.Truncated AS PartNumber
, dbo_EPS_EPSResistanceTester_Meas.PartSN AS SerialNumber
, PartListTruncated.TestType
, dbo_EPS_EPSResistanceTester_Meas.ResistanceTestDate AS TestDate
, dbo_EPS_EPSResistanceTester_Meas.Good
, dbo_EPS_EPSResistanceTester_Meas.Resistance
FROM
PartListTruncated
INNER JOIN
dbo_EPS_EPSResistanceTester_Meas
ON
PartListTruncated.Part_Number = dbo_EPS_EPSResistanceTester_Meas.PartNumber
WHERE
(
(
(
dbo_EPS_EPSResistanceTester_Meas.PartSN
)
>=[sns]
And
(
dbo_EPS_EPSResistanceTester_Meas.PartSN
)
<=[sne]
)
AND
(
(
dbo_EPS_EPSResistanceTester_Meas.ResistanceTestDate
)
>=[ds]
And
(
dbo_EPS_EPSResistanceTester_Meas.ResistanceTestDate
)
<=[de]
)
AND
(
(
dbo_EPS_EPSResistanceTester_Meas.PartNumber
)
=[tn]
)
)
;
【问题讨论】：