Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


11461 / 13646 ツリー ←次へ | 前へ→

【15856】アクセスへデータの貼り付け tamago 04/7/9(金) 13:37 質問[未読]
【15857】Re:アクセスへデータの貼り付け IROC 04/7/9(金) 13:39 回答[未読]
【15862】Re:アクセスへデータの貼り付け tamago 04/7/9(金) 14:41 発言[未読]
【15869】Re:アクセスへデータの貼り付け IROC 04/7/9(金) 16:13 回答[未読]
【15871】Re:アクセスへデータの貼り付け ichinose 04/7/9(金) 16:26 発言[未読]
【15951】Re:アクセスへデータの貼り付け tamago 04/7/13(火) 9:36 発言[未読]
【15980】Re:アクセスへデータの貼り付け ichinose 04/7/13(火) 21:13 回答[未読]
【15983】Re:アクセスへデータの貼り付け 訂正 ichinose 04/7/13(火) 21:53 発言[未読]
【15985】Re:アクセスへデータの貼り付け 訂正 しん 04/7/13(火) 23:07 発言[未読]
【15988】Re:アクセスへデータの貼り付け 訂正 ichinose 04/7/13(火) 23:36 発言[未読]
【15991】Re:アクセスへデータの貼り付け 訂正 しん 04/7/14(水) 0:39 お礼[未読]

【15856】アクセスへデータの貼り付け
質問  tamago  - 04/7/9(金) 13:37 -

引用なし
パスワード
   A1 部品型式  B1 電算コード C1 メーカー名 D1 メーカーコード    
E1 No.       F1  弊社方針 G1 大分類  H1 物質名
I1 含有の有無 有=○/無=空白" J1 含有率(ppm)

 
上記の列見出しに基づいて入力されているエクセルデータがあります。
このデータよりI列に"○"が入力されているデータをオートフィルタで抜き出したのち、
ganyuデータベースのganyuテーブルにデータを直接貼り付けたいのです。
 
VBAは超初心者なのですが、ご指導よろしくお願いします。

【15857】Re:アクセスへデータの貼り付け
回答  IROC  - 04/7/9(金) 13:39 -

引用なし
パスワード
   mdbファイルへのデータの追加ですか?

【15862】Re:アクセスへデータの貼り付け
発言  tamago  - 04/7/9(金) 14:41 -

引用なし
パスワード
   ▼そうです。mdbファイルへのデータの追加です。
よろしくお願いいたします。

【15869】Re:アクセスへデータの貼り付け
回答  IROC  - 04/7/9(金) 16:13 -

引用なし
パスワード
   ADO や DAO というものを利用します。

http://www.vbasekai.com/tipsdao.html

【15871】Re:アクセスへデータの貼り付け
発言  ichinose  - 04/7/9(金) 16:26 -

引用なし
パスワード
   IROCさん、tamagoさん、こんにちは。

>ADO や DAO というものを利用します。
↑これは、必要みたいですね!!

で、tamagoさん、
入力データとしてのExcelシートの形式はわかりましたが、
このシートに入るデータを3例ぐらい挙げてください。

それから、出力データについては何も記述されていませんが、
シートの構成とまったく同じフィールドだけで構成されているテーブル
(ganyuテーブル)を想定すればよいのですか?(出来たらテーブルのデータ型も)

もうちょっと詳しく聞かなければはっきりとは言えませんが、
○のデータのみmdbファイルに追加するのであれば、オートフィルタは必要ないかも
しれませんよ!!

【15951】Re:アクセスへデータの貼り付け
発言  tamago  - 04/7/13(火) 9:36 -

引用なし
パスワード
   ▼A1 部品型式  B1 電算コード C1 メーカー名 D1 メーカーコード    
E1 No.       F1  弊社方針 G1 大分類  H1 物質名
I1 含有の有無 有=○/無=空白" J1 含有率(ppm)

フィールド型は全てテキスト型です。
データ例
 GP4327  643511B  オムロン 1043 1  禁止  金属化合物  水銀 ○
 1000
このような感じです。I列が含有がある場合○と入力し、ない場合は空白になっています。どうぞよろしくお願いします。
ADOについてはほんの少しわかる程度です。


>このシートに入るデータを3例ぐらい挙げてください。
>
>それから、出力データについては何も記述されていませんが、
>シートの構成とまったく同じフィールドだけで構成されているテーブル
>(ganyuテーブル)を想定すればよいのですか?(出来たらテーブルのデータ型も)
>
>もうちょっと詳しく聞かなければはっきりとは言えませんが、
>○のデータのみmdbファイルに追加するのであれば、オートフィルタは必要ないかも
>しれませんよ!!

【15980】Re:アクセスへデータの貼り付け
回答  ichinose  - 04/7/13(火) 21:13 -

引用なし
パスワード
   ▼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("追加したいDB,(*.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("追加したいDB,(*.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
'オートフィルタを使用して指定された条件にあったA列のセルを取得する
'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


確認して下さい。




【15983】Re:アクセスへデータの貼り付け 訂正
発言  ichinose  - 04/7/13(火) 21:53 -

引用なし
パスワード
   >'==============================================================
>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
↑を以下に訂正
'===================================================================
Function put_rs(rng As Range) As Long
  On Error GoTo err_put_rs
  put_rs = 0
  With rs
   .AddNew
   For idx = 1 To rng.Count
     .Fields(idx - 1).Value = rng.Cells(idx).Value
     Next idx
   .Update
   End With
ret_put_rs:
  On Error GoTo 0
  Exit Function
err_put_rs:
  put_rs = Err.Number
  MsgBox Error(Err.Number)
  Resume ret_put_rs
End Function


>もうひとつの方法は、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("追加したいDB,(*.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
      call close_rs '←これ入れといて下さい
>      End If
>     MsgBox "データ追加成功"
>     close_db
>     End If
>   End If
>End Sub

【15985】Re:アクセスへデータの貼り付け 訂正
発言  しん E-MAIL  - 04/7/13(火) 23:07 -

引用なし
パスワード
   ▼ichinose さん:
こんばんは、お久しぶりです。
このマクロに興味があったので、実例で試してみたのですが
mainの

flnm = Application.GetOpenFilename("追加したいDB,(*.mdb)")

のところで処理が進まなくなってしまいます。すなわち、適当なDB名を入力して「開く」をクリックあるいは「×」をクリックしても前へ進みません。ちなみに
このステートメントの直後に

MsgBox flnm

を挿入してflnmの値を見ますとFALSEとなっています。
そうだとすれば、Accessへの書き込み処理はされなく処理停止となってなってしまうのはやむを得ないですね。どこに問題があるのでしょうか?教えて下さい。

私のプラットホームは

Windows XP Pro & Office XP Pro

です。
>>'==============================================================
>>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
>↑を以下に訂正
>'===================================================================
>Function put_rs(rng As Range) As Long
>  On Error GoTo err_put_rs
>  put_rs = 0
>  With rs
>   .AddNew
>   For idx = 1 To rng.Count
>     .Fields(idx - 1).Value = rng.Cells(idx).Value
>     Next idx
>   .Update
>   End With
>ret_put_rs:
>  On Error GoTo 0
>  Exit Function
>err_put_rs:
>  put_rs = Err.Number
>  MsgBox Error(Err.Number)
>  Resume ret_put_rs
>End Function
>
>
>>もうひとつの方法は、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("追加したいDB,(*.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
>      call close_rs '←これ入れといて下さい
>>      End If
>>     MsgBox "データ追加成功"
>>     close_db
>>     End If
>>   End If
>>End Sub

【15988】Re:アクセスへデータの貼り付け 訂正
発言  ichinose  - 04/7/13(火) 23:36 -

引用なし
パスワード
   ▼しん さん:
こんばんは。


>このマクロに興味があったので、実例で試してみたのですが
>mainの
>
>flnm = Application.GetOpenFilename("追加したいDB,(*.mdb)")
>
>のところで処理が進まなくなってしまいます。すなわち、適当なDB名を入力して「開く」をクリックあるいは「×」をクリックしても前へ進みません。ちなみに
>このステートメントの直後に
>
>MsgBox flnm
>
>を挿入してflnmの値を見ますとFALSEとなっています。
>そうだとすれば、Accessへの書き込み処理はされなく処理停止となってなってしまうのはやむを得ないですね。どこに問題があるのでしょうか?教えて下さい。
>
>私のプラットホームは
>
>Windows XP Pro & Office XP Pro
>
>です。
WinXPは持っていませんので、確認できませんが
Win2000&Excel2002で確認しました。正常に作動していますが・・・・。
(投稿時はEXCEL2000で確認)

お聞きした内容だと

'========================================================
Sub test()
    flnm = Application.GetOpenFilename("追加したいDB,(*.mdb)")
    MsgBox flnm
End Sub

上記のコードが常に「False」と言う事になりますよね?

そうだとしたら、???です。
>「×」をクリックしても前へ進みません
は、キャンセルと同じですから、Falseになりますが・・・。
再度、確認してください。

【15991】Re:アクセスへデータの貼り付け 訂正
お礼  しん E-MAIL  - 04/7/14(水) 0:39 -

引用なし
パスワード
   ▼ichinose さん:
ichinoseさんの結果とどうして違うのかなとよく考え直してみて初めてわかりました。
私は保存先のAccessファイルは名前を適当に指定すれば、そのファイルにExcelファイルの内容が(○の付いたレコードだけ)自動的に書き込まれるのかなと思っていたのですが、そうではなくて、あらかじめ指定したいファイル名のAccessDBファイルを作り、しかもそのDBにはあらかじめSheet1と同じフィールド名を持ったganyuという名前のテーブルを作っておかなければならなかったのですね。
どうも私の早とちりですみまzせんでした。
Windows XP Pro & Office XP ProでもWindows 2000 Pro & Office 2000 Proでも、どちらの組み合わせでも正常に動作することが確認できました。
ありがとうございます。

11461 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free