在显示“ 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]
)
)
;
答案 0 :(得分：0)
我从来没有弄清楚它为什么会损坏，但是将记录集类型从DAO记录集更改为ADODB记录集是可行的。
已添加
Dim f1 As DAO.Field
Dim rs3 As DAO.Recordset
已更改
Dim rs2 As ADODB.Recordset
然后，我更改了记录集的删除方式。
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 rs3 = qry.OpenRecordset(dbOpenSnapshot)
If rs3.RecordCount > 0 Then
Set rs2 = New ADODB.Recordset
rs2.Fields.Append "PartNumber", adVarChar, 255, adFldKeyColumn
rs2.Fields.Append "SerialNumber", adInteger, , adFldKeyColumn
rs2.Fields.Append "TestType", adVarChar, 255
rs2.Fields.Append "TestDate", adDate
rs2.Fields.Append "Good", adVarChar, 255
rs2.Fields.Append "Resistance", adDouble
rs2.Open
rs3.MoveFirst
While Not rs3.EOF
rs2.AddNew
For Each f1 In rs3.Fields
rs2.Fields(f1.Name).Value = f1.Value
Next
rs2.Update
rs3.MoveNext
Wend
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
End If