| |
かおピ さん、こんばんわ。
>Sheet1 の日々の日計表の２名の条件と一致するものを
>Sheet2 の中から探し、
>A:月 B:日 C:名前 D:金額 E:入金日 F:担当者
>4 1 鈴木一郎 1050
>4 1 浅田真央 980
>4 2 田口 壮 2000 4/9 片山
>4 4 鈴木一郎 550 4/9 松田
> このように、入金日と担当者を転記したいのです。
担当者名が完全一致検索できて、重複がないとして。
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet, r1 As Range
Dim s1 As String, s2 As String, RR As Long, Rmax As Long
'シートセット
With Application.ActiveWorkbook
Set ws1 = .Worksheets("Sheet1") '転記元
Set ws2 = .Worksheets("Sheet2") '転記先
End With
'検索をかけて、ヒットしたら転記（重複はないとする）
Rmax = ws2.Range("C65536").End(xlUp).Row
For RR = 2 To Rmax
If ws2.Cells(RR, 3).Value <> "" Then
With ws1.Columns(2)
Set r1 = .Find(what:=ws2.Cells(RR, 3).Value, After:=.Cells(1))
If Not r1 Is Nothing Then
'
Do
s1 = r1.Address
If r1.Offset(0, 1).Value = ws2.Cells(RR, 1).Value And _
r1.Offset(0, 2).Value = ws2.Cells(RR, 2).Value And _
r1.Offset(0, 3).Value = ws2.Cells(RR, 4).Value Then
'
'Sheet1のCDEとSheet2のABDが一致したら
ws2.Cells(RR, 5).Value = r1.Offset(0, -1).Value
ws2.Cells(RR, 6).Value = r1.Offset(0, 4).Value
Exit Do 'Loop終了
End If
Set r1 = .FindNext(r1)
Loop While Not r1 Is Nothing And r1.Address <> s1
End If
End With
End If
Next
'
Set r1 = Nothing
Set ws1 = Nothing: Set ws2 = Nothing
End Sub
こんな感じです。
|
|
りん
- 07/4/9(月) 19:30 -
