Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

41331 / 76736

←次へ　｜　前へ→


	【40486】Re:検索して一致したらデータ入力

ichinose - 06/7/14(金) 18:45 -


	引用なし

	パスワード

▼涙さん：
こんばんは。

>>シートＡ(リスト）
>
>　　　　A　　　　Ｂ　　　　Ｃ
>1　　　　　　ID1　　　　ID2　　　　　　氏名
>2　　　　　　　AAA　　　　111　　　　　中田
>3　　　　BBB　　　　222　　　　　宮本
>4　　　　CCC　　　　333　　　　　中村
>5　　　　DDD　　　　444　　　　　川口
>
>
>シートＢ
>　　　　A　　　　Ｂ　　　　Ｃ　　　　Ｄ　　　　
>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　　　　Ｂ　　　　Ｃ　　　　Ｄ　　　　
>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("シートＡ")
　　　 Set rng1 = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
　　　 End With
　　With Worksheets("シートＢ")
　　　 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

で試してみてください

0 hits

▼

【40481】検索して一致したらデータ入力 涙 06/7/14(金) 15:33