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