Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

65399 / 76807

←次へ　｜　前へ→


	【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("追加したいＤＢ,(*.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

2 hits

▼

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