VBで条件に合ったセルを含む行に色を付けたいのですが…

質問

VBで条件に合ったセルを含む行に色を付けたいのですが…

条件に合ったセルを含む行に色を付けたいのですが…

いつもお世話になってます。
VB初心者ですが、こちらでご指導頂きながら勉強しております。

今回もアドバイスお願い致しますm(__)m

G列～R列で"未作業"という文字が入ったセルがあれば、
その行に色を付けたいのです。

ただし、同じ行に"発注済"という文字が入ったセルがあれば、
行に色は付けなくてもよいです。

さらに、色の付いた行のみ次のシートにデータコピーしたいのですが…

何かよい方法はありますでしょうか？

回答No.3

n-jun

データの範囲がＡ列からＲ列とし、色もその範囲につける。
Ｇ列は１～５０と固定しているが、必要な時は最終行を取得して下さい。

Sub　try()
　Dim　r　As　Range
　Dim　r1　As　Range,　r2　As　Range

　Set　r2　=　Worksheets("Sheet2").Range("A1")
　　　　　For　Each　r　In　Range("G1:G50")
　　　　　　　　　With　WorksheetFunction
　　　　　　　　　　　　　　If　.CountIf(r.Resize(,　12),　"発注済")　=　0　And　_
　　　　　　　　　　　　　　　　　.CountIf(r.Resize(,　12),　"未作業")　>　0　Then
　　　　　　　　　　　　　　　　　　Set　r1　=　Intersect(r.EntireRow,　Range("A:R"))
　　　　　　　　　　　　　　　　　　r1.Interior.ColorIndex　=　6　'黄色
　　　　　　　　　　　　　　　　　　r1.Copy　r2
　　　　　　　　　　　　　　　　　　Set　r2　=　r2.Offset(1)
　　　　　　　　　　　　　　End　If
　　　　　　　　　End　With
　　　　　Next
　Set　r1　=　Nothing
　Set　r2　=　Nothing
End　Sub

ご参考になれば。

回答No.2

nda23

こんな感じですかね。
Sub 処理()
Dim 自, 範, 次, 未, 済, 行&, 新&
Set 自 = Worksheets(1) '対象シート
Set 範 = 自.Columns("G:R") '検索対象列範囲
Set 未 = 範.Find("未作業") '"未作業"を探す
If 未 Is Nothing Then Exit Sub '無ければ終了
Set 次 = Worksheets(2) 'コピー先シート
次.Select
Do
　　行 = 未.Row
　　With 自.Rows(CStr(行) & ":" & CStr(行))
　　　　Set 済 = .Find("発注済") '"発注済"を探す
　　　　If 済 Is Nothing Then '見つからない場合の処理
　　　　　　.Interior.ColorIndex = 3 '色指定
　　　　　　.Copy '行コピー
　　　　　　新 = 新 + 1 'コピー先行位置
　　　　　　次.Cells(新, 1).Select 'コピー先を選択
　　　　　　次.Paste '貼り付け
　　　　　　Application.CutCopyMode = False 'モード解除
　　　　End If
　　End With
　　Set 未 = 範.Find("未作業", After:=自.Cells(行, 18)) '次を探す
Loop Until 行 > 未.Row '次の行が前より小さくなったら終了
End Sub
※コピー先のシートをクリアするとか入ってないので、適当に入れて
ください。

回答No.1

nattocurry

色をつける作業に関しては、VBAを使わなくても、実現できますよ。

VBAの勉強のために、あえてVBAでやろうとしているのでしょうか？
それとも、VBAじゃないと無理そうだと判断して、VBAでやろうとしているのでしょうか？