| |
いつもお世話になっております。
http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=9612;id=excel
でエクセルから、アクセスへのインポート仕方を教えていただきました。
丁寧に教えてくださり、感謝しております。
マクロを実行したところ、
「各段階のOLE DBの操作でエラーが発生しました。
各OLE DBの状態の値をチェックしてください。
作業は終了しませんでした。」というエラーになってしまったので、
もう少し教えて頂けないでしょうか？
'===============================================================
Public cn As New ADODB.Connection
Public rs As New ADODB.Recordset
'===============================================================
Function open_ado(book_fullname As String) As Long
On Error Resume Next
link_opt = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & book_fullname
' ↑のよけいなストリングを省くだけ
と教えて頂いたのですが、何をすれば良いでしょうか？
教えて頂いたモジュールは、下記のように貼り付けてあります。
何か間違っているところがあるのでしょうか？
お手数をお掛けして申し訳ないのですが
よろしくお願いします。
Module７に
'==========================================================
Sub access()
Dim sql_str As String
If open_ado("アクセスのある場所\アクセスのファイル名.mdb") = 0 Then
sql_str = "select * from テーブル名"
If open_rs(sql_str) = 0 Then
With ActiveSheet
Set rng = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
If rng.Row > 1 Then
For idx = 1 To rng.Count
If add_rs(rng.Cells(idx).Resize(1, 22)) <> 0 Then
Exit For
End If
Next idx
Else
MsgBox "アクティブシートにデータなし"
End If
rs_close
End If
close_ado
Else
MsgBox "接続失敗"
End If
End Sub
Module１に
'===============================================================
Public cn As New ADODB.Connection
Public rs As New ADODB.Recordset
'===============================================================
Function open_ado(book_fullname As String) As Long
On Error Resume Next
link_opt = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & book_fullname
' ↑のよけいなストリングを省くだけ
cn.Open link_opt
open_ado = Err.Number
On Error GoTo 0
End Function
'===============================================================
Sub close_ado()
On Error Resume Next
cn.Close
On Error GoTo 0
End Sub
'===============================================================
Function open_rs(sql_str As String) As Long
On Error Resume Next
rs_close
rs.Open sql_str, cn, adOpenStatic, adLockOptimistic
If Err.Number <> 0 Then
MsgBox Error$(Err.Number)
End If
open_rs = Err.Number
On Error GoTo 0
End Function
'===============================================================
Function add_rs(rng As Range) As Long
On Error GoTo err_add_rs
With rs
.AddNew
For idx = 1 To rng.Count
.Fields(idx).Value = rng.Cells(idx).Value
' 第1フィールドをオートナンバにしたので、第２フィールドからテーブルに
' 追加
Next idx
.Update
End With
add_rs = 0
ret_add_rs:
On Error GoTo 0
Exit Function
err_add_rs:
MsgBox Error$(Err.Number)
add_rs = Err.Number
Resume ret_add_rs
End Function
'===============================================================
Sub rs_close()
On Error Resume Next
rs.Close
On Error GoTo 0
End Sub
|
|
