エクセルのマクロについて教えてください

質問

お世話になっております。

エクセルのマクロについて教えていただきたいのですが、

サンプルのファイルをこちらにアップしたのでよろしければご覧になってください。
http://kie.nu/yPV

質問したいことは、列Iに、各行の黄色いセルの数を表示させるマクロを作りたいのですが
途中まで何とかわかったのですがどうもうまくいきません。。

行11から各行にひとつずつ、黄色いセルが含まれていますが、その黄色いセルの中の数字を列Iに表示させたいです。行にデータがある限り、下までずっとです。

以下、途中までわかったマクロです。

Sub 黄セル値Copy()
Const TgLeftUp = "A3" '<--対象範囲左上セル指定
Dim Rng As Range
Dim Target As Range
Set Target = Range(TgLeftUp, Cells(Rows.Count, _
Range(TgLeftUp).Column))
For Each Rng In Target.Resize(, 2)
If Rng.Interior.ColorIndex = 6 Then
If Rng.Column = Target.Column Then
Rng.Offset(, 3).Value = Rng.Value
Else
Rng.Offset(, 2).Value = Rng.Value
End If
End If
Next
MsgBox "値 貼り付け完了。", vbInformation
Set Target = Nothing
End Sub

でもこれを貼り付けてもうまくいきません。

正しいマクロを教えていただけないでしょうか？？

宜しくお願いいたします。

※いつも、私の質問に対してまるで回答になってないような、ふざけた言葉を書き込んでは消してる方が一名だけいらっしゃいます。確か、鳥の写真をマイページに載せてる方です。
都度違反報告はしていますが、質問の趣旨に反する回答をされてる方一名、絶対にやめてください。

回答No.2

WindFaller · ベストアンサー

こんにちは。

#1さんと大差ないですが、こんな感じです。こちらは、しばらく、条件付き書式になっていることに気が付かなかったです。これは、質問文に書いてくださるようにお願いします。必ずしも、外部のファイルをダウンロードするとは限りませんから。

'//
Sub ColorCheck()
　Const TgLeftUp = "C11" '<--対象範囲左上セル指定
　Const vCOL = 9 '値を貼り付ける列
　Dim cSTART As Range
　Dim rng As Range
　Dim c As Range
　Dim i As Long
　Set cSTART = Cells(Range(TgLeftUp).Row, vCOL)
　Set rng = Range(cSTART, Cells(Rows.Count, vCOL - 1).End(xlUp))
　Application.ScreenUpdating = False
　For Each c In rng
　　i = WordsChecker(c.Text)
　　If i > 0 Then
　　　Cells(c.Row, vCOL).Value = Cells(c.Row, i).Text
　　End If
　Next c
　Application.ScreenUpdating = True
　MsgBox "値 貼り付け完了。", vbInformation
　Set rST = Nothing
End Sub
Function WordsChecker(arg1 As Variant)
'セルの内容が変わったら一意の語を抽出して、変更してください。
　If InStr(1, arg1, "遅刻し", 1) Then ret = 3　'列数
　If InStr(1, arg1, "予約時間後検査", 1) Then ret = 5
　If InStr(1, arg1, "予約時間よりも早く", 1) Then ret = 6
　WordsChecker = ret
End Function

今回のように条件付き書式そのもので判定することは、不可能に近いことです。VBAでは、条件付き書式の色の判定そのものは、とてもややこしいからです。わざわざ、条件付き書式で求めるよりも、最初から、H列目の文言を含めて、マクロの表示にしてしまえば、全部が一気に出来上がります。条件付き書式と同じようオンタイム（イベント・ドリブン型）で、色塗りも可能です。

お礼

こんににちは！
条件付書式のことを書いておらず申し訳ありませんでした。

大変勉強になりました。
お蔭様で表を完成させることができました。

有難うございました！！！

回答No.1

tom04

こんばんは！
せっかくコードをお考えなのに余計なお世話かもしれませんが・・・

Sub test()
Dim i As Long
Dim j As Long
Dim k As Long
Dim cL As Long
Dim myArray As Variant
myArray = Array("遅刻", "開始", "実施") '←H列に含まれる条件を格納

For i = 11 To Cells(Rows.Count, 1).End(xlUp).Row
For k = 0 To UBound(myArray)
If InStr(Cells(i, 8), myArray(k)) > 0 Then
j = k
End If
Next k
Select Case j
Case 0
cL = 3
Case 1
cL = 5
Case Else
cL = 6
End Select

If cL = 5 Then
Cells(i, 9).NumberFormatLocal = "[m]"
Else
Cells(i, 9).NumberFormatLocal = "G/標準"
End If
Cells(i, 9) = Cells(i, cL)
Next i
MsgBox "処理が終了しました。"
End Sub

※　じっくり考えればもっと早く処理ができる方法があるかもしれません。
こんなんで参考になりますかね？m(_ _)m

お礼

こんばんは！回答いただき有難うございます！！

余計なお世話でないですよ！すごく助かりました！

おかげさまで無事表示させることができました。
勉強になりました。