Excel VBA質問箱 IV

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

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


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

32592 / 76734

←次へ　｜　前へ→


	【49377】Re:条件に対して条件の場所に転記したい。

りん

- 07/6/3(日) 9:00 -


	引用なし

	パスワード

かおピさん、おはようございます。

>>このようにsheet1の訂正１と訂正２に上記のような数字が入ったら
>>sheet2の受１．受２．受３へ数字を転記したいです。
>>ただし、・・・＊のようにsheet1の訂正１に数字が入らず訂正２に１が入っても
>>転記はしない。（基準は、訂正１にあります。）
>>sheet2の訂正日は、当日の日付（５/３１）を転記したいです。
>>よろしくお願いします。

ベタに転記していくなら。
Option Explicit
Sub test()
　 Dim ws(1 To 2) As Worksheet
　 Dim RR As Long, Rpos As Long, Rmax As Long, CC As Integer
　 With Application.ThisWorkbook
　　　Set ws(1) = .Worksheets("Sheet1") '元
　　　Set ws(2) = .Worksheets("Sheet2") '先
　 End With
　 '
　 Rmax = ws(1).Range("A65536").End(xlUp).Row
　 Rpos = ws(2).Range("A65536").End(xlUp).Row
　 '表は２行目から開始
　 For RR = 2 To Rmax
　　　With ws(1)
　　　　 '訂正1に1が入っている場合、訂正２に何が入っているかで分岐
　　　　 Select Case .Cells(RR, 4).Value
　　　　　　Case 1: If .Cells(RR, 5).Value = 1 Then CC% = 3 Else CC% = 1
　　　　　　Case 2:　　CC% = 2
　　　　　　Case Else: CC% = 0
　　　　 End Select
　　　　 '転記先の列位置(CC%)が０以外の時に転記する
　　　　 If CC% = 0 Then
　　　　　　.Rows(RR).Interior.ColorIndex = 38
　　　　 Else
　　　　　　Rpos = Rpos + 1
　　　　　　ws(2).Cells(Rpos, 1).Value = Date
　　　　　　ws(2).Cells(Rpos, 2).Value = .Cells(RR, 1).Value
　　　　　　ws(2).Cells(Rpos, 2 + CC%).Value = .Cells(RR, 2).Value 'CDE
　　　　　　ws(2).Cells(Rpos, 6).Value = .Cells(RR, 3).Value
　　　　 End If
　　　End With
　 Next
　 Erase ws
End Sub
こんな感じです。
動作チェックのために、転記しなかった行に色を塗っています。

なお、処理対象のデータ件数がものすごく多い場合は、配列に入れた方が転記の処理は格段に速くなります。

6 hits

▼

【49309】条件に対して条件の場所に転記したい。 かおピ 07/5/31(木) 0:46