|
>'==============================================================
>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
|
|