|
Private Sub Command0_Click()
Dim rs As New ADODB.Recordset
Dim rst As New ADODB.Recordset
Dim Conn As New ADODB.Connection
Dim I, J As Integer
Dim strSQL As String
Dim strName, strSheetName As String
On Error GoTo Command0_Click_Error
strName = CurrentProject.Path & "\nlc1.xls"
strSheetName = "sheet1"
Conn.Open _
"Provider=Microsoft.Jet.OLEDB.4.0; Persist Security Info=False;Data Source=" _
& strName & "; Extended Properties='Excel 8.0;HDR=Yes'"
strSQL = "select * [" & strSheetName & "$]"
rs.Open strSQL, Conn, adOpenKeyset, adLockReadOnly
Do While Not rs.EOF
Select Case rs.Fields("处理2")
Case "非发酵", "肠杆"
J = 3
Case "葡萄球"
J = 2
Case Else
J = 1
End Select
rst.Open "a", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
For I = 1 To J
With rst
.AddNew
.Fields(0) = rs.Fields(0)
.Fields(1) = rs.Fields(1)
.Fields(2) = rs.Fields(2)
.Fields(3) = rs.Fields(3)
.Fields(4) = rs.Fields(4)
.Fields(5) = rs.Fields(5)
.Fields(6) = rs.Fields(6)
.Fields(7) = I
End With
Next
rst.UpdateBatch
rst.Close
rs.MoveNext
Loop
rs.Close
Conn.Close
Set Conn = Nothing
Set rs = Nothing
Set rst = Nothing
Me.A_子窗体.Requery
On Error GoTo 0
Exit Sub
Command0_Click_Error:
MsgBox " " & Err.Number & " (" & Err.Description & ")"
End Sub
http://www.accessbbs.cn/bbs/viewthread.php?tid=16353&extra=&highlight=%2Bmickle009&page=2
[ 本帖最后由 Henry D. Sy 于 2008-12-19 23:18 编辑 ] |
|