マクロで色のついたセルへ移動

質問

色の付いたセルへの移動方法で教えて下さい。

添付した画像のような時の場合に
例えばD2セルにカーソルがあって
マクロを実行すると
そこから次の塗りつぶし（10～16行）のD16に移動するには
どうすればいいですか？

色の付いていないセル（画像でいうと7、9行目）と、
アクティブのセルの色と同じ色がある場合は、
その部分は抜かしたいです（画像でいうと8行目）

色は限定というわけではないので
アクティブセルの色と違う色を見つけた場合に
その色の塊の一番最後のD列のセルに移動するという感じです。

D16で実行すると次はD19
D19で実行すると次はD31

という感じの事が行いたいです。
ネット色々調べましたが似たような記事はこれぐらいしかありませんでした。
http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1090112035

宜しくお願いします。

回答No.3

kagakusuki · ベストアンサー

下記のマクロは、マクロを起動させた時点において、複数のセルを選択中であったり、図形などのセル以外のオブジェクトを選択中であってもエラーとならない様にするため、Selectionを使わずにActiveCellを基準にして処理を行う様にしています。
　又、選択中のセルよりも下には、そのセルとは異なる色で塗られたセルが存在していない場合には、セルの移動は行わず、その代わりに
「選択されているセルの下には、選択されているセルとは異なる色で塗りつぶされているセルは存在しません」
という表示が現れる様になっております。

Sub QNo9134099_マクロで色のついたセルへ移動()

Dim c As Range, LastRow As Long, myBoolean As Boolean, myRange As Range

With ActiveSheet.UsedRange
LastRow = .row + .Rows.Count
End With
myBoolean = False
If ActiveCell.row <= LastRow Then
Set myRange = Range(ActiveCell, Cells(LastRow, ActiveCell.column))
For Each c In Range(ActiveCell, Cells(LastRow, ActiveCell.column))
myBoolean = False
With c.Interior
If Not myBoolean Then myBoolean = _
.Pattern <> c.Offset(1).Interior.Pattern _
And .Pattern <> ActiveCell.Interior.Pattern _
And .Pattern <> xlNone
If Not myBoolean Then myBoolean = _
.PatternColorIndex <> c.Offset(1).Interior.PatternColorIndex _
And .PatternColorIndex <> ActiveCell.Interior.PatternColorIndex _
And .PatternColorIndex <> xlNone
If Not myBoolean Then myBoolean = _
.Color <> c.Offset(1).Interior.Color _
And .Color <> ActiveCell.Interior.Color _
And .Color <> 16777215
If Not myBoolean Then myBoolean = _
.TintAndShade <> c.Offset(1).Interior.TintAndShade _
And .TintAndShade <> ActiveCell.Interior.TintAndShade _
And .TintAndShade <> 0
If Not myBoolean Then myBoolean = _
.PatternTintAndShade <> c.Offset(1).Interior.PatternTintAndShade _
And .PatternTintAndShade <> ActiveCell.Interior.PatternTintAndShade _
And .PatternTintAndShade <> 0
End With
If myBoolean Then
c.Select
Exit For
End If
Next c
End If
If Not myBoolean Then MsgBox "選択されているセルの下には、" _
& "選択されているセルとは異なる色で塗りつぶされているセルは存在しません" _
, vbInformation, "無効な選択"

End Sub

お礼

いつもいつもありがとうございます。

また「こんな時の場合の為に」
ということで、色々なパターンをご用意して頂きありがとうございました。

今後ともよろしくお願いします。

回答No.2

ushi2015

こんにちは
データを入力したら、ではなくて、ただマクロを実行したらですか？
Sub test()
　　Dim a As Range
　　Dim r As Range
　　Dim t As Range
　　Dim i As Variant
　　Dim j As Long
　　Dim k As Long

　　Set a = ActiveCell

　　i = a.Interior.ColorIndex

　　With Intersect(ActiveSheet.UsedRange, a.EntireColumn)
　　　　On Error Resume Next
　　　　j = .SpecialCells(xlCellTypeLastCell).Row
　　　　If Err.Number <> 0 Then On Error GoTo 0: Exit Sub
　　　　On Error GoTo 0
　　　　For k = j To 1 Step -1
　　　　　　If .Cells(k, 1).Interior.ColorIndex <> xlNone Then
　　　　　　　　Exit For
　　　　　　End If
　　　　Next
　　End With

　　If k <= a.Row Then Exit Sub

　　Set t = a.Offset(1)
　　Do
　　　　If t.Interior.ColorIndex = xlNone Then
　　　　　　Set t = t.Offset(1)
　　　　ElseIf t.Interior.ColorIndex = a.Interior.ColorIndex Then
　　　　　　Set t = t.Offset(1)
　　　　Else
　　　　　　t.Select
　　　　　　Exit Do
　　　　End If
　　Loop
　　Do
　　　　If t.Interior.ColorIndex <> t.Offset(1).Interior.ColorIndex Then
　　　　　　t.Select
　　　　　　Exit Do
　　　　Else
　　　　　　Set t = t.Offset(1)
　　　　End If
　　Loop

End Sub

お礼

今回はただ単にマクロを実行したらということでした。
頂いた、マクロでも目的は果たせました！

ありがとうございました！

今後ともよろしくお願いします。

回答No.1

chie65536（@chie65535）

「その色の塊」と言うのは難しい（塊が「単純な四角形とは限らない」）ので「カーソルのある列」しか見ません。

Sub Macro1()
Dim CursorRow As Long
Dim CursorCol As Integer
Dim LookRow As Long
Dim NewRow As Long
Dim EndRow As Long
Dim MaxRow As Long
Dim CurColor As Integer
Dim NewColor As Integer

CursorRow = Selection.Row
CursorCol = Selection.Column
CurColor = Selection.Interior.ColorIndex
MaxRow = Selection.SpecialCells(xlLastCell).Row

NewRow = -1
For LookRow = CursorRow To MaxRow
If Cells(LookRow, CursorCol).Interior.ColorIndex <> xlNone And Cells(LookRow, CursorCol).Interior.ColorIndex <> CurColor Then
NewRow = LookRow
NewColor = Cells(LookRow, CursorCol).Interior.ColorIndex
Exit For
End If
Next
If NewRow <> -1 Then
EndRow = -1
For LookRow = NewRow To MaxRow
If Cells(LookRow, CursorCol).Interior.ColorIndex <> xlNone Then
If Cells(LookRow, CursorCol).Interior.ColorIndex = NewColor Then
EndRow = LookRow
End If
If Cells(LookRow, CursorCol).Interior.ColorIndex <> NewColor Then
Exit For
End If
End If
Next
If EndRow <> -1 Then
Cells(EndRow, CursorCol).Select
End If
End If
End Sub

お礼

完璧でした！
ありがとうございました！

今後ともよろしくお願いします。