|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
新建文件夹.rar
(58.07 KB, 下载次数: 30)
各位,我是一个刚接触ACCESS的,现在附件中的文件在运行时提示出错,请各位指点下!
附件传不上来,只可以复制代码过来,出错在红色字处.
Public Sub 将工作表数据保存到已有的ACCESS数据库1()
Dim myData As String, myTable As String
Dim wb As Workbook
Dim ws As Worksheet
Dim i As Long, j As Long
Dim myCat As New ADOX.Catalog
Dim myCmd As ADODB.Command
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Set wb = ThisWorkbook
Set ws = wb.Sheets("数据库")
myData = wb.Path & "\myData.mdb"
myTable = "数据库"
If Dir(myData) = "" Then
myCat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & myData
Set cnn = myCat.ActiveConnection
Set myCmd = New ADODB.Command
Set myCmd.ActiveConnection = cnn
myCmd.CommandText = "CREATE TABLE " & myTable _
& "(序号 text,日期 date,物料名称 text(50),规格 text(50)," _
& " 采购单号 text(50),收发单号 text(50),PN text(50),款号 text(50)," _
& " 色号 text(50),收发 text(50),均码 Single,XXS Single,XS Single," _
& " S Single,M Single,L Single,XL Single,XXL Single,3XL Single," _
& " 4XL Single,5XL Single,小计 Single,备注 text(50))"
myCmd.Execute , , adCmdText
Else
Set cnn = New ADODB.Connection
With cnn
.Provider = "microsoft.jet.oledb.4.0"
.Open myData
End With
Set rs = cnn.OpenSchema(adSchemaTables)
Do Until rs.EOF
If LCase(rs!table_name) = LCase(myTable) Then GoTo hhh
rs.MoveNext
Loop
Set myCmd = New ADODB.Command
Set myCmd.ActiveConnection = cnn
myCmd.CommandText = "CREATE TABLE " & myTable _
& "(序号 text,日期 date,物料名称 text(50),规格 text(50)," _
& " 采购单号 text(50),收发单号 text(50),PN text(50),款号 text(50)," _
& " 色号 text(50),收发 text(50),均码 Single,XXS Single,XS Single," _
& " S Single,M Single,L Single,XL Single,XXL Single,3XL Single," _
& " 4XL Single,5XL Single,小计 Single,备注 text(50))"
myCmd.Execute , , adCmdText
hhh:
End If
n = ws.Range("A65536").End(xlUp).Row
For i = 2 To n
Sql = "select * from " & myTable _
& " where 日期=" & Format(ws.Cells(i, 2).Value, "yyyy-mm-dd") & " " _
& " and 物料名称=" & ws.Cells(i, 3).Value & " " _
& " and 规格=" & ws.Cells(i, 4).Value & " " _
& " and 采购单号=" & ws.Cells(i, 5).Value _
& " and 收发单号=" & ws.Cells(i, 6).Value _
& " and PN=" & ws.Cells(i, 7).Value _
& " and 款号=" & ws.Cells(i, 8).Value _
& " and 色号=" & ws.Cells(i, 9).Value _
& " and 收发=" & ws.Cells(i, 10).Value _
& " and 均码=" & ws.Cells(i, 11).Value _
& " and XXS=" & ws.Cells(i, 12).Value _
& " and XS=" & ws.Cells(i, 13).Value _
& " and S=" & ws.Cells(i, 14).Value _
& " and M=" & ws.Cells(i, 15).Value _
& " and L=" & ws.Cells(i, 16).Value _
& " and XL=" & ws.Cells(i, 17).Value _
& " and XXL=" & ws.Cells(i, 18).Value _
& " and 3XL=" & ws.Cells(i, 19).Value _
& " and 4XL=" & ws.Cells(i, 20).Value _
& " and 5XL=" & ws.Cells(i, 21).Value _
& " and 小计=" & ws.Cells(i, 22).Value _
& " and 备注=" & ws.Cells(i, 23).Value
Set rs = New ADODB.Recordset
rs.Open Sql, cnn, adOpenKeyset, adLockOptimistic
If rs.RecordCount = 0 Then
rs.AddNew
For j = 1 To rs.Fields.Count
rs.Fields(j - 1) = ws.Cells(i, j).Value
Next j
rs.Update
Else
For j = 1 To rs.Fields.Count
rs.Fields(j - 1) = ws.Cells(i, j).Value
Next j
rs.Update
End If
Next i
MsgBox "数据保存完毕！", vbInformation + vbOKOnly
rs.Close
cnn.Close
Set wb = Nothing
Set ws = Nothing
Set rs = Nothing
Set myCmd = Nothing
Set myCat = Nothing
Set cnn = Nothing
End Sub |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2008-11-9 11:49
楼主
