|
▼涙 さん:
こんばんは。
>>シートA(リスト)
>
> A B C
>1 ID1 ID2 氏名
>2 AAA 111 中田
>3 BBB 222 宮本
>4 CCC 333 中村
>5 DDD 444 川口
>
>
>シートB
> A B C D
>1 年月日 ID1 ID2 料金
>2 6/1 AAA 111 6300
>3 6/3 BBB 222 3000
>4 6/5 CCC 333 4000
>5 6/7 AAA 111 9000
>6 6/10 CCC 333 4000
>4 6/12 BBB 222 8000
>8 6/20 AAA 111 7000
>
><ほしい結果>
>シートB
> A B C D
>1 年月日 ID1 ID2 料金
>2 6/1 AAA 111 6300
>3 6/3 BBB 222 3000
>4 6/5 CCC 333 4000
>5 6/7 AAA 111 9000
>6 6/10 CCC 333 4000
>4 6/12 BBB 222 8000
>8 6/20 AAA 111 7000
>8 DDD 444 1000
>
標準モジュールに
'===============================================================
Sub main()
Dim rng1 As Range
Dim rng2 As Range
Dim crng As Range
Dim nrw As Long
With Worksheets("シートA")
Set rng1 = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
End With
With Worksheets("シートB")
Set rng2 = .Range("b2", .Cells(.Rows.Count, "b").End(xlUp))
End With
If rng1.Row > 1 Then
If rng2.Row > 1 Then
nrw = 0
For Each crng In rng1
If Evaluate("=SUM(EXACT(" & rng2.Address(, , , True) & "," & crng.Address(, , , True) & ")*1)") = 0 Then
With rng2
.Cells(.Rows.Count + 1 + nrw, 1).Resize(, 2).Value = crng.Resize(, 2).Value
.Cells(.Rows.Count + 1 + nrw, 3).Value = 1000
End With
nrw = nrw + 1
End If
Next
Else
With rng2
.Cells(2, 1).Resize(rng1.Rows.Count, 2).Value = rng1.Resize(, 2).Value
.Cells(2, 3).Resize(rng1.Rows.Count).Value = 1000
End With
End If
End If
End Sub
で試してみてください
|
|