| |
こんにちは、ハトです。
小林さんのに付け加える形で考えてみました
もっとうまいやり方があるかもしれませんが、試してみてください
▼小林 さん：
>お世話になっています。
>いつも参考にさせてもらっています。
>
>2つのシートを比較して一致する行を別シートに移動したいのですが
>やり方がわからず、困っています。
>
>以下のマクロは、請求したものが支払明細にあるかの検索マクロですが、
>これを変更したいのです。
>
>Worksheets("vicky-com")は当社のデータで、com社への請求明細です。（10列あります。）
>Worksheets("com")はcom社からの支払明細です。（15列あります。）
>Worksheets("vicky-com")のG列は請求番号、Worksheets("com")のI列は支払番号で
>当社の請求番号を使ってもらっています。（紐付けされています。）
>当社の請求番号で検索して該当したらWorksheets("hit")へ、行を移動したいのです。
>
>Worksheets("vicky-com")の該当の行（10列分）をWorksheets("hit")のAからJ列へ、Worksheets("com")の該当の行（15列分）をKからY列へ同じ行に並べて書きたいのです。
>
>アドバイス願えないでしょうか？
>よろしくお願いいたします。
>Sub test()
> Dim myArea1 As Range
> Dim myArea2 As Range
> Dim R As Range
> Dim C As Range
> Dim SearchKey As String
> Dim firstAddress As String
> Dim ws1 As Worksheet
> Dim ws2 As Worksheet
> Dim ws3 As Worksheet
'ws3での行カウント用カウンタ
Dim pos As Long
>
> Set ws1 = Worksheets("vicky-com")
> Set ws2 = Worksheets("com")
> Set ws3 = Worksheets("hit")
> Set myArea1 = ws1.Range("G1", Range("G65536").End(xlUp))
> Set myArea2 = ws2.Range("I:I")
'カウンタの初期化、画面更新抑止
pos = 1
Application.ScreenUpdating = False
>
> For Each R In myArea1
> SearchKey = R.Value
> Set C = myArea2.Find(What:=SearchKey, LookIn:=xlValues, LookAt:=xlWhole)
>
> If Not C Is Nothing Then
> firstAddress = C.Address
> Do
> R.Offset(, 4).Value = "該当"
'ws1の該当行（A列からJ列）をws3（A列からJ列）へコピー
ws1.Select
ws1.Range(Cells(R.Row, 1), Cells(R.Row, 10)).Copy _
Destination:=ws3.Cells(pos, 1)
'ws2の該当行（A列からO列）をws3（K列からY列）へコピー
ws2.Select
ws2.Range(Cells(C.Row, 1), Cells(C.Row, 15)).Copy _
Destination:=ws3.Cells(pos, 11)
'ws3の書込み行のカウンタを更新
pos = pos + 1
> Set C = myArea2.FindNext(C)
> Loop While Not C Is Nothing And C.Address <> firstAddress
> End If
> Next R
'画面更新再開
ws1.Select
Application.ScreenUpdating = True
>
>End Sub
|
|
ハト
- 06/4/23(日) 15:33 -
