| |
▼tamago さん：
こんばんは。
二通りの方法を投稿します。
ADOを使用しました。参照設定で
「Microsoft ActiveX Data Objects x.x Library」にチェックを入れて下さい。
二通りの方法の共通プロシジャー群です。
標準モジュール（Module2）に、
'==============================================================
Public cn As New ADODB.Connection
Public rs As New ADODB.Recordset
'==============================================================
Function open_db(flnm As String) As Long
'Mdbファイルへの接続
'Input : flnm Mdbファイルのフルパス
'output : open_db リターンコード 0正常 その他:異常
On Error Resume Next
With cn
.ConnectionString = "provider=Microsoft.jet.OLEDB.4.0;" & "Data Source=" & flnm
.Open
End With
If Err.Number <> 0 Then
MsgBox Error$(Err.Number)
open_db = Err.Number
Else
open_db = 0
End If
On Error GoTo 0
End Function
'==============================================================
Function sql_exec(str_sql As String) As Long
'指定されたSQLの実行
'Input : str_sql sql構文
'output : sql_exec リターンコード 0正常 その他:異常
On Error Resume Next
cn.Execute str_sql
If Err.Number <> 0 Then
MsgBox Error(Err.Number)
sql_exec = Err.Number
Else
sql_exec = 0
End If
On Error GoTo 0
End Function
'==============================================================
Function open_rs(tblnm As String) As Long
'テーブルへの接続
'input tblnm : テーブル名
'output open_rs : リターンコード 0正常 その他:異常
On Error Resume Next
rs.Open tblnm, cn, adOpenStatic, adLockOptimistic
If Err.Number <> 0 Then
MsgBox Error$(Err.Number)
open_rs = Err.Number
Else
open_rs = 0
End If
On Error GoTo 0
End Function
'==============================================================
Function put_rs(rng As Range) As Long
'データのセット
'input : rng : 書き込みセル範囲
'output: put_rs リターンコード 0正常 その他:異常
On Error Resume Next
With rs
.AddNew
For idx = 1 To rng.Count
.Fields(idx - 1).Value = rng.Cells(idx).Value
Next idx
.Update
End With
On Error GoTo 0
End Function
'==============================================================
Sub close_rs()
'テーブル接続解除
On Error Resume Next
rs.Close
On Error GoTo 0
End Sub
'==============================================================
Sub close_db()
'Mdbファイルへの接続解除
On Error Resume Next
cn.Close
Set cn = Nothing
On Error GoTo 0
End Sub
サンプルのExcelブック名は、「ganyuexcel.xls」
対象シート名は「Sheet1」とします。
二つの方法共に書き込むデータベースファイル（Mdbファイル）は、ダイアログにて
指定する仕様です。
次に第一の方法です。
SQL文で○の検索から書き込みまでしてしまいます。
オートフィルタは使用しません。
（但し、Sheet1の項目名とMdbファイルの書き込みテーブルのフィールド名は
一致している事とします）
'===================================================================
Sub main()
Dim c_db As String
Dim mysql As String
flnm = Application.GetOpenFilename("追加したいＤＢ,(*.mdb)")
If flnm <> False Then
c_db = flnm
If open_db(c_db) = 0 Then
mysql = "INSERT INTO ganyu SELECT * FROM [Excel 8.0;Database=" & ThisWorkbook.Path & "\ganyuexcel.xls]" & _
".[Sheet1$] where" & "[Sheet1$].[含有の有無 有=○/無=空白] = '○';"
If sql_exec(mysql) = 0 Then
MsgBox "データ追加成功"
End If
close_db
End If
End If
End Sub
もうひとつの方法は、tamago さんがおっしゃっていたオートフィルタを使いました。
'=======================================================================
Sub main2()
Dim c_db As String
Dim rng As Range
Dim crng As Range
Set rng = get_match_rng("=○") 'オートフィルタで条件に合うセル範囲の取得
If rng Is Nothing Then Exit Sub
flnm = Application.GetOpenFilename("追加したいＤＢ,(*.mdb)")
If flnm <> False Then
c_db = flnm
If open_db(c_db) = 0 Then
If open_rs("ganyu") = 0 Then
For Each crng In rng
If put_rs(crng.Resize(, 10)) <> 0 Then
Stop
End If
Next
End If
MsgBox "データ追加成功"
close_db
End If
End If
End Sub
'==========================================================
Function get_match_rng(cond As String) As Range
'オートフィルタを使用して指定された条件にあったＡ列のセルを取得する
'cond 条件文字列
Dim a_rng As Range
Set get_match_rng = Nothing
Set a_rng = Range("a1", Cells(Rows.Count, 1).End(xlUp))
If a_rng.Count = 1 Then Exit Function
With a_rng.Resize(, 10)
.AutoFilter
.AutoFilter Field:=9, Criteria1:=cond
End With
On Error Resume Next
Set get_match_rng = a_rng.SpecialCells(xlCellTypeVisible)
a_rng.Resize(, 10).AutoFilter
If Err.Number = 0 Then
Set get_match_rng = Application.Intersect(get_match_rng, Range("a2", Cells(Rows.Count, 1).End(xlUp)))
End If
On Error GoTo 0
End Function
確認して下さい。
|
|
ichinose
- 04/7/13(火) 21:13 -
