| |
おはようございます。
>貼り付け後VLOOKUPするのもどうかと思ってます
ADOのFindメソッドを使ってみました。
>配達者一覧（Access側）
>地域｜配達者
>大阪｜太郎
>京都｜次郎
>東京｜三郎
このテーブルがsample1.mdbというmdbファイルにあるとして・・・。
(テーブル名やフィールド名も上記のとおりだとして）
Excel側は、新規ブックにて
標準モジュール(Module1)に
'=====================================================
Sub mk_sample()
With ActiveSheet
.Range("a1:b5").Clear
.Range("a1:b1").Value = Array("地域名", "日々配達者")
.Range("b2:b5").Value = [{"三郎";"次郎";"一郎";"太郎"}]
End With
End Sub
上記mk_sampleを実行してみてください。
アクティブシートにサンプルデータが作成されます。
作成されたデータに対して、地域名を設定するＶＢＡを考えます。
実際のコードです。
別の標準モジュール（Module2）にADO I/Oプロシジャー群
'================================================================
Private cn As Object
Function open_db(dbpath As String) As Long
On Error GoTo err_open_db
open_db = 0
foldnm = ThisWorkbook.Path & "\"
Set cn = CreateObject("ADODB.Connection")
cn.ConnectionString = "provider=Microsoft.jet.OLEDB.4.0;" & "Data Source=" & dbpath
cn.Open
On Error GoTo 0
Exit Function
err_open_db:
MsgBox Error(Err.Number) & Err.Number
open_db = Err.Number
End Function
'================================================================
Sub close_db()
On Error Resume Next
cn.Close
Set cn = Nothing
On Error GoTo 0
End Sub
'================================================================
Function execute_sql(sql As String, grs As Object) As Long
On Error GoTo err_sql
close_rs grs
execute_sql = 0
grs.Open sql, cn, adOpenStatic, adLockPessimistic
ret_err_sql:
On Error GoTo 0
Exit Function
err_sql:
MsgBox Error(Err.Number) & Err.Number
execute_sql = Err.Number
Resume ret_err_sql
End Function
'================================================================
Sub close_rs(grs As Object)
On Error Resume Next
grs.Close
End Sub
別の標準モジュール(Module3）に、サンプルデータを加工するコード
'===========================================================
Sub test()
Dim rs As Object
Dim rng As Range
Dim crng As Range
With ActiveSheet
Set rng = .Range("b2", .Cells(.Rows.Count, "b").End(xlUp))
End With
If rng.Row > 1 Then
Set rs = CreateObject("adodb.recordset")
If open_db(ThisWorkbook.Path & "\sample1.mdb") = 0 Then
If execute_sql("配達者一覧", rs) = 0 Then
rng.Offset(0, -1).ClearContents
For Each crng In rng
rs.Find "配達者 = '" & crng.Text & "'", , adSearchForward, 1
If rs.EOF <> True Then
crng.Offset(0, -1).Value = rs!地域
End If
Next
Call close_rs(rs)
End If
Call close_db
End If
Set rs = Nothing
End If
Set rng = Nothing
Set crng = Nothing
End Sub
testを実行してみてください。
Ａ Ｂ
１ 地域名 日々配達者
２ 東京 三郎
３ 京都 次郎
４ 一郎
５ 大阪 太郎
こんな結果になりました。
試してみてください。
|
|
ichinose
- 10/5/25(火) 6:58 -
