Excel VBAに付いて質問します。

質問

VBAを使いまして、決まった範囲以内のセルの中に色を付けたいと考えています。
決まった範囲内とは、セルの横に14マス縦に6マスの合計84個のマスのセルがあります。
セルM2を個数の入力セルに20と数字を入力すると14×6マスの右上から左に向かって20個のセルに色を付けます。
この時、横のセルの数が14マスなので、その下の列から右から左に向かって6マスを色を付くようにします。
そうすると合計20個のセルが色が付くようにしたいのです。
もちろん、例えば、30と入力したら30個のセルを右上から左に向かって30個のセルの中が色が付くようにしたいと考えています。この様なVBAを作りたいと考えています。
この動作をコマンドボタンで動作できる様に教えて下さい。
初心者の為、説明が不足している部分もありますが、よろしくお願いします。

回答No.8

tom04 · ベストアンサー

No.3・4です。
さらなる追加質問でどういったコトをやりたいのか、判り難くなったような気がします。

（1）どうしても「42」の数値に目が行ってしまいますので・・・
単に範囲指定した部分を4等分にして色分けしたいのか？

（2）コマンドボタンを二つ配置して2アクション必要なのか？

（3）コマンドボタン1で「黄色」にしておいて、コマンドボタン2の部分の色変更だけではダメなのか？

等々余計に判らなくなってしまいました。

まぁ～！それはさておいて・・・

質問内容をそのまま受け取ると
「コマンドボタン1」はそのままでOKだと思います。

「コマンドボタン2」にもう一度「コマンドボタン1」のFor～NextのLoopを追加してみてはどうでしょうか？

Private Sub CommandButton2_Click()
Dim i, j, k As Long
For j = 15 To 2 Step -1
For i = 9 To 4 Step -1
k = k + 1
If k <= Range("M2") Then
If Cells(i, j).Interior.ColorIndex = xlNone Then
Cells(i, j).Interior.ColorIndex = 5
Else
Cells(i, j).Interior.ColorIndex = 6
End If
End If
Next i
Next j

For i = 4 To 9
For j = 15 To 2 Step -1
k = 0
k = k + 1
If k <= Range("M2") Then
If Cells(i, j).Interior.ColorIndex = 6 Then
Cells(i, j).Interior.ColorIndex = 3
ElseIf Cells(i, j).Interior.ColorIndex = 3 Then
Cells(i, j).Interior.ColorIndex = 6
End If
End If
Next j
Next i
End Sub

※　無理矢理のコードなので、回りくどいコードになってしまいました。
こんな感じをお望みなのでしょうかね？m(_ _)m

お礼

どうもすいません。これが本当の私が望んだ動作になっています。
手短に話ますと・・・コマンドボタン1の動作が並び替えする前の状態です。
並び替えする時、コマンドボタン2の状態に並び替えするように結果がを知る事が出来きます。
コマンドボタン２で変色した箇所が移動前と移動後を現しています。
tom04さんのコードを使いますと黄色が移動前で青が異動後の箇所を示します。
変色した部分のみ移動する事が分かるようになった。
これが私が行いたかったことです。
説明が下手なところがありましたが、感謝しています。
本当にありがとうございました。

補足

42の数字を表現したのは84のちょうど半分で2分割して説明ができると思いました事から42の数字を表現に使いました。
返って分かりにくくして・・・ごめんなさい。

回答No.7

end-u

>>セルM2に84と入力すればB4：O９までの範囲がすべて色を変わる事になります。
>だったらこんな感じですね。
ごめんなさい、間違った。
>With Range("B3").Resize(y, x)
ここはB4でした。
With Range("B4").Resize(y, x)

ついでにtry_2の修正版。
Sub try_6()
　　Const y = 6　'タテ
　　Const x = 14 'ヨコ
　　Dim a　As String
　　Dim s1 As String
　　Dim s2 As String
　　Dim f1 As String
　　Dim f2 As String

　　With Range("B4")
　　　　a = .Address
　　　　s1 = "$M$2"
　　　　s2 = "$N$2"
　　　　'"$M$2>=(ROW()-ROW($B$4))*14 + 14-COLUMN()+COLUMN($B$4)"
　　　　f1 = s1 & ">=(ROW()-ROW(" & a & "))*" & x
　　　　f1 = f1 & "+" & x & "-COLUMN()+COLUMN(" & a & ")"
　　　　'"$N$2>=(14-COLUMN()+COLUMN($B$4)-1)*6+6-ROW()+ROW($B$4)"
　　　　f2 = s2 & ">=(" & x & "-COLUMN()+COLUMN(" & a & ")-1)*" & y
　　　　f2 = f2 & "+" & y & "-ROW()+ROW(" & a & ")"
　　　　'条件付き書式設定
　　　　With .Resize(y, x).FormatConditions
　　　　　　.Delete
　　　　　　.Add(Type:=xlExpression, _
　　　　　　　　　　Formula1:="=AND(" & f1 & "," & f2 & ")" _
　　　　　　　　　　).Interior.ColorIndex = 3
　　　　　　.Add(Type:=xlExpression, _
　　　　　　　　　　Formula1:="=" & f1 _
　　　　　　　　　　).Interior.ColorIndex = 4
　　　　　　.Add(Type:=xlExpression, _
　　　　　　　　　　Formula1:="=" & f2 _
　　　　　　　　　　).Interior.ColorIndex = 5
　　　　End With
　　End With
End Sub
右上から左方向への個数をM2セルに。
右下から上方向への個数をN2セルに入力。
常に同じ個数だったら s2 = "$M$2" でも良いですが。

お礼

この条件付き書式を使ってVBAコードを作成するのは、凄く素晴らしいです。
この条件付き書式を使うことで、パソコンへの負荷もへりスペックの低いパソコンでも簡単に動作が出来るようです。
初心者ですが、素晴らしく感謝しています。
ありがとうございました。

回答No.6

end-u

>セルM2に84と入力すればB4：O９までの範囲がすべて色を変わる事になります。
だったらこんな感じですね。
Sub try_4()
　　Const y = 6　'タテ
　　Const x = 14 'ヨコ
　　Dim r As Long
　　Dim c As Long
　　Dim i As Long

　　'起点からタテy、ヨコx に対して処理
　　With Range("B3").Resize(y, x)
　　　　.Interior.ColorIndex = xlNone
　　　　c = x
　　　　r = 1
　　　　Do Until i >= Range("M2").Value
　　　　　　.Item(r, c).Interior.ColorIndex = 1
　　　　　　If c = 1 Then
　　　　　　　　c = x
　　　　　　　　r = r + 1
　　　　　　　　If r > y Then Exit Do
　　　　　　Else
　　　　　　　　c = c - 1
　　　　　　End If
　　　　　　i = i + 1
　　　　Loop
　　End With
End Sub

ついでに右下から上へのパターン
Sub try_5()
　　Const y = 6　'タテ
　　Const x = 14 'ヨコ
　　Dim r As Long
　　Dim c As Long
　　Dim i As Long

　　'起点からタテy、ヨコx に対して処理
　　With Range("B3").Resize(y, x)
　　　　c = x
　　　　r = y
　　　　Do Until i >= Range("M2").Value
　　　　　　With .Item(r, c).Interior
　　　　　　　　If .ColorIndex = 1 Then
　　　　　　　　　　.ColorIndex = 2
　　　　　　　　Else
　　　　　　　　　　.ColorIndex = 3
　　　　　　　　End If
　　　　　　End With
　　　　　　If r = 1 Then
　　　　　　　　r = y
　　　　　　　　c = c - 1
　　　　　　　　If c < 1 Then Exit Do
　　　　　　Else
　　　　　　　　r = r - 1
　　　　　　End If
　　　　　　i = i + 1
　　　　Loop
　　End With
End Sub

お礼

ご回答ありがとうございます。希望した動作が出来るようになりました。
本当助かりました。改めてお礼を申し上げます。
自分なりに勉強をしようと思い始めましたが、なかなか難しく進歩が全くない状態です。
ですが、ヘルプを読んだりして何とか意味を理解する事が出来ますが・・・
基本が抜けているのか・・・コード組立ができない状態です。
今回は、本当にありがとうございます。

回答No.5

end-u

>これが具体的にはどの範囲なのでしょう。
>例えばM2セルの右14×6なのでしょうか？（N2:AA7？）
このお答えが頂けないようで。

『B4を起点』とは？
M2ではなくて
A3セルに個数を入力してその『右下』B4を起点にするという事でしょうか？
それとも
B4セルに個数を入力してその『右下』C5を起点にするという事でしょうか？
とりあえず前者。

Sub try_3()
　　Const y = 6　'タテ
　　Const x = 14 'ヨコ
　　Dim r As Long
　　Dim c As Long
　　Dim i As Long

　　With Range("A3")
　　　　'A3から下1,右1オフセット、タテy、ヨコx に対して処理
　　　　.Offset(1, 1).Resize(y, x).Interior.ColorIndex = xlNone
　　　　c = x
　　　　r = 1
　　　　Do Until .Value <= i
　　　　　　.Offset(r, c).Interior.ColorIndex = 1
　　　　　　If c = 1 Then
　　　　　　　　c = x
　　　　　　　　r = r + 1
　　　　　　　　If r > y Then Exit Do
　　　　　　Else
　　　　　　　　c = c - 1
　　　　　　End If
　　　　　　i = i + 1
　　　　Loop
　　End With
End Sub

自分で修正して使う事が出来なければ、他の方のコードの方をおすすめします。
理解できる方法が良いと思いますよ。

マクロの動作確認方法など、基本的なところも学んでおいたほうが良いでしょう。
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_030.html

補足

質問の回答が遅れました、14×6の範囲は、B4：O9としています。
B4：O9で84マスのセルを作っています。
範囲の選択には、教えて頂いた後に自分で変更しようかと思っていましたので・・・重視はしていませんでしたが、上記記載が範囲となります。
そして最初のM2のセルですが・・・M２に数字を入れ色を変えるセルの個数としています。
セルM2に84と入力すればB4：O９までの範囲がすべて色を変わる事になります。
なので、最初の回答の”With ActiveCell”をM2を選択できる様にできたらと思いました。
お手数をおかけしました、

回答No.4

tom04

No.3です。

追加質問について・・・
セル範囲は前回と同じとします。
コマンドボタン2を配置するとして

（1）コマンドボタン1でM2セルの数だけ「赤」にする
（2）コマンドボタン2でM2セルの数だけ右下から上に向かって「青」にする
（3）すでに「赤」の色が付いているセル（重複するセル）は「黄色」にする
という感じでやっています。

Private Sub CommandButton2_Click()
Dim i, j, k As Long
For j = 14 To 1 Step -1
For i = 8 To 3 Step -1
k = k + 1
If k <= Range("M2") Then
If Cells(i, j).Interior.ColorIndex = xlNone Then
Cells(i, j).Interior.ColorIndex = 5
Else
Cells(i, j).Interior.ColorIndex = 6
End If
End If
Next i
Next j
End Sub

※　コマンドボタン1　→　コマンドボタン2の順で操作してください。

こんな感じをお望みですかね？
的外れならごめんなさいね。m(__)m

お礼

度々のご回答ありがとうございます。結果的に言いますと、希望した動作ができました。まさしくこの動作です。私の説明内容で、ここまで理解して頂きました事、本当にありがとうございました。
最後に欲を言えば・・・tom04さんのコードを使って数量のM2に42と入力して動作させてみますと、赤・青・黄色の三色が均等に色が変わります。
黄色と赤の所を逆に動作ができると完璧です。
最初のコマンドボタン１で赤色のセルになります。そしてコマンドボタン２で赤色の所が黄と青になります。そして最初の赤が残ります。
この時の最初の赤色の部分を黄色にしコマンドボタン２で黄色になった所を変色させない様には、難しいですよね？
現時点でも不自由はありませんので、問題はないのですが・・・時間がある時にでも教えて下さい。
今回は、本当に助かりました。いろんな方にご回答頂きまして感謝しています。

回答No.3

tom04

こんばんは！
14列×6行の範囲が判らないので、勝手に
C3セル～N8セルの範囲としてやってみました。
（セルの色は「赤」にしています）
コマンドボタンを配置しているとして・・・

Private Sub CommandButton1_Click()
Dim i, j, k As Long
Cells.Interior.ColorIndex = xlNone
For i = 3 To 8 '←3行目～8行目
For j = 14 To 1 Step -1 '←14列（N列）～1列（A列）まで
k = k + 1
If k <= Range("M2") Then
Cells(i, j).Interior.ColorIndex = 3
End If
Next j
Next i
End Sub

※　範囲部分は実際のデータに合わせてやってみてください。

こんなんではどうでしょうか？m(_ _)m

お礼

ご回答ありがとうござます。ばっちり希望の動作が出来きました。
この様な動作でもう一つ希望したい動作があるんですが、こちらで続き質問しても良いんでしょうか？
上手くに説明ができるか分からないですが・・・今回の希望しました動作は完璧にできる様になったんですが、今回の動作に合わせて、もう一つのコマンドボタン2を用意しまして、84マスのセルの右下を起点として上に向かってセルの色を変えたいです。
最初の質問と同じ様に、42個とM2のセルに入力したら右下を起点として上に6マス色をかえ左の列に行き下から上へと42マスセルの色をかえます。
問題なのは、これからなんですが、最初の質問でセルの色を右上を起点としてセルの色を変えました、今度は、右下を起点として上に向かってセルの色をかえるんですが、この時、最初に色を変えた箇所のセルは、そのまま色を変えず空白のセルのみ色を変え42個のセルを別の色でかえます。
42個のセルを変える訳ですが、最初のセルの色を含めたうえで42個のセルを変える様にしたいです。

確認ですが、最初の動作で42個のセル右上を起点とし42個変えます。
そうすると上から3段目全部が色が変わります。
次に右下を起点とし42個セルを変えます。この時、空白のセルのみ変えるので右下から3段目から左へ7列変わり、結果、合計で21個のセルが変わるようになります。
この場合、最初に変えたセルでそのまま変色しないセルがありますが、できれば、そこの部分のみ別な色を使って変える事ができるといいのですが・・・

分かりにくい説明ですが、お手数ですがご協力して頂きたいと思います。

回答No.2

end-u

>決まった範囲内とは、セルの横に14マス縦に6マスの合計84個のマスのセルがあります。
これが具体的にはどの範囲なのでしょう。
例えばM2セルの右14×6なのでしょうか？（N2:AA7？）
そこが不明なので、取り敢えずアクティブセルを起点として考えてみます。
M2セルをアクティブにして実行。

Sub try()
　　Const y = 6　'タテ
　　Const x = 14 'ヨコ
　　Dim r As Long
　　Dim c As Long
　　Dim i As Long

　　With ActiveCell
　　　　'アクティブセルを起点にするから限界域設定
　　　　If .Row > (Rows.Count - y + 1) Or _
　　　　　 .Column > (Columns.Count - x) Then Exit Sub
　　　　　 '起点から右1オフセット、タテy、ヨコx に対して処理
　　　　　 .Offset(, 1).Resize(y, x).Interior.ColorIndex = xlNone
　　　　　　c = x
　　　　　　Do Until .Value <= i
　　　　　　　　.Offset(r, c).Interior.ColorIndex = 1
　　　　　　　　If c = 1 Then
　　　　　　　　　　c = x
　　　　　　　　　　r = r + 1
　　　　　　　　　　If r >= y Then Exit Do
　　　　　　　　Else
　　　　　　　　　　c = c - 1
　　　　　　　　End If
　　　　　　　　i = i + 1
　　　　　　Loop
　　End With
End Sub

もう一つお遊びで
Sub try_2()
　　Const y = 6　'タテ
　　Const x = 14 'ヨコ
　　Dim s As String
　　Dim r As String
　　Dim c As String

　　With ActiveCell
　　　　If .Row > (Rows.Count - y + 1) Or _
　　　　　 .Column > (Columns.Count - x) Then Exit Sub
　　　　s = .Address
　　　　r = "(Row()-Row(" & s & "))*" & x
　　　　c = x & "-COLUMN()+COLUMN(" & s & ")+1"
　　　　'条件付き書式設定
　　　　With .Offset(, 1).Resize(y, x).FormatConditions
　　　　　　.Delete
　　　　　　'"=$M$2 >= (ROW()-ROW($M$2))*14 + 14-COLUMN()+COLUMN($M$2)+1"みたいな式
　　　　　　.Add(Type:=xlExpression, _
　　　　　　　　 Formula1:="=" & s & ">=" & r & "+" & c _
　　　　　　　　 ).Interior.ColorIndex = 1
　　　　End With
　　End With
End Sub
条件付き書式なので手動でもできたりします。
VBAの勉強にはならないでしょうけど。

お礼

ご回答ありがとうございます。見ただけで・・・凄すぎて、なんて言ったら良いか分からいなですが・・・凄いですの一言です。アクティブセルじゃなくて例えば・・・B4を起点とする場合は、Cells(2,4)としてもダメだったんですが、どの様にしたら良いでしょうか？

回答No.1

11zep

説明は、省きます。がんばって勉強して下さい。

If Cells(2, 13).Value = "" Then Exit Sub
If Cells(2, 13).Value > 84 Or Cells(2, 13).Value < 1 Then
MsgBox ("M2に入力された値が不正です。")
Exit Sub
End If

Dim ColCnt As Integer
Dim RowCnt As Integer
Dim CellCnt As Integer

CellCnt = 0
For RowCnt = 2 To 15
For ColCnt = 9 To 4 Step -1
CellCnt = CellCnt + 1
Cells(RowCnt, ColCnt).Select
Selection.Interior.Color = 65535
If CellCnt = Cells(2, 13).Value Then Exit For
Next ColCnt
If CellCnt = Cells(2, 13).Value Then Exit For
Next RowCnt
Cells(3, 13).Select

お礼

ご回答ありがとうございます。 いろいろ勉強をさせて頂きたいと思います。
その為、ベストアンサーを決めるのに時間が必要となりますので、すいませんがよろしくお願いします。分からない点がありましたら補足にて質問します。