|
▼hana さん:
こんにちは。
>各個人のファイルから、直接mdbファイルへの
>エクスポートを試みたのですが、
>Access Opject Libraryを使用する方法しか
>分からなかったので、この方法を取っています。
>(Accessの入っていないパソコンでは、
>参照設定にこの項目が無かったのです。)
なるほど、そういうことですか・・・。
逆に言えばAccessのないPCでも
「Microsoft ActiveX Data Objects 2.X Library」は、参照できていますね?
ならは、mdbファイルにアクティブシートの内容を直接書き込む事はできます。
しかも、Excelブックへの書き込みコードをちょっと変更するだけで・・・。
アクティブシートのデータは、
A列からV列で、
>数値は、A〜D、F〜Q、T、Uの列に入っています。
だとし、
mdbファイル(仮にExportmdb.mdbとしましょう)の書き込みテーブルの
テーブル名を「T_Test」としてみます。
テーブルT_Testの第1フィールドは、IDとし、オートナンバーにしました(これが主キー)。
第2〜第23フィールドは、アクティブシートのA列〜V列に対応する属性に設定しておきます。
テーブル構成の全体がわかりませんので、上記のような構成を例にあげると、
標準モジュール(Module1)に
'==========================================================
Sub main()
Dim sql_str As String
If open_ado(ThisWorkbook.Path & "\Exportmdb.mdb") = 0 Then
sql_str = "select * from T_Test"
'変更したのは、↑とその上の行のファイル名だけ
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
標準モジュール(Module2)に
'===============================================================
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フィールドをオートナンバにしたので、第2フィールドからテーブルに
' 追加
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
というよに簡単な変更で直接mdbファイルに追加できます。
現行で完成してしまったら、仕方ないですが、
試してみていけそうでしたら、こっちの方がよいのではないでしょうか?
|
|