指定した数字の塗りつぶしの無理難題です

塗りつぶしの方法はわかりますが、厄介な感じで困ってます。
A1に名前を入れ、B1に数量、C1にMAX値が入ります。
A4からB2に入力した数量が塗りつぶすようにし、MAX値になったらA5に残り塗りつぶされるようにしたくいのですが可能でしょうか？
また、名前が何種類かあるので例えば、A2の名前の数量がA6から自動に塗りつぶされるようにしてみたいです。理想の写真を添付します。お力添えお願いいたします。
※写真とセルが少し違いますがご了承下さい。

質問者からの補足コメント

• 詳しく作成頂きありがどうございます。
  補足までありがとうございます。
  まだ出先で手元にpcがないため試してなく、またマクロ等かなりの初心者なのでせっかく作成していただいのにこんな質問申し訳ないんですが、コピペしたらすぐに使える状態でしょうか？補足以外にセルを入れなきゃいけない等はありますか？

  No.3の回答に寄せられた補足コメントです。 補足日時：2019/07/09 19:08

• 早々に再回答ありがとうございます。
  早速入れてみたのですが、下記部分で「構文エラー」がでるのはなぜでしょうか？
  ド素人のような質問で申し訳ないです。
  
  Range(START_COLUMN & START_ROW & ":" & END_COLUMN & END_ROW).Interior.ColorIndex = 0
  End Sub

  No.5の回答に寄せられた補足コメントです。 補足日時：2019/07/09 21:47

No.6 回答者： taku-9023.ham 回答日時： 2019/07/09 22:38

Sub DePaintCell()

Const START_COLUMN As String = "E", START_ROW As Integer = 2
Const END_COLUMN As String = "P", END_ROW As Integer = 100

Range(START_COLUMN & START_ROW & ":" & END_COLUMN & END_ROW).Interior.ColorIndex = 0
End Sub
のひとかたまりで入力しましたか？①

少々説明不足でしたが、
START_COLUMN,　　 START_ROW, 　　END_COLUMNの入力は２カ所あり、
どちらとも設定しておく必要があります。②

二個とも試してみてダメだったら、すみませんがもう一回
Optional Explicit から
｜
End Function までコピってみてください。

それでもダメだったら
Range(.... の方でエラーか End Subのところでエラーか教えてください。

No.5 回答者： taku-9023.ham 回答日時： 2019/07/09 20:45

いえ、セルへの入力はありません。

ただし、
NAME_NUM, 　　START_COLUMN,　　 START_ROW, 　　END_COLUMN
の設定が必要です。一番左に「Const」と書いてあるところを探せば見つかります。

質問者さんの質問では、どこのセルから塗り始めるのかよくわからなかったので、設定できるようにしておきました。
START_COLUMN はマス目の一番左上のセルの行、START_ROWはその列です。
END_COLUMN はマス目の一番右上のセルの行です。

例えば、J3 からAR3までマス目があるとき、
START_COLUMN As String = "J"　<-ここ!!　,START_ROW As Integer = 3 <- ここ!!
END_COLUMN As String = "AR" <-ここ!!　　　　　　　　　　　　　　　　　　　　　(一部省略)
とすればいいです。


※ごめんなさい。訂正です。※
最悪は直さなくてもいいですが、END_COLUMNの設定を間違えるとバグります。注意してください。

-----------------------------------
If value(1, i) <= 0 Then
now_row = now_row + 1
Exit Do
ElseIf j - Rows_address(START_COLUMN) + 1 >= value(2, i) Then
now_row = now_row + 1
Exit For
End If
Next
-----------------------------------
これを下のように直しておいてください。

-----------------------------------
If value(1, i) <= 0 Then
now_row = now_row + 1
Exit Do
ElseIf j - Rows_address(START_COLUMN) + 1 >= value(2, i) Then
now_row = now_row + 1
Exit For
End If
If j = Rows_address(END_COLUMN) Then　
now_row = now_row + 1　　　　　　　　　
End If　　　　　　　　　　　　　　　　　　　
Next
----------------------------------

あと補足見づらくなってしまってすみません。
Aセルに名前、Bセルに数量、Cセルに最大値を入力すればいいと言うことです。

何度も長文で申し訳ありません。お力になれれば幸いです。

No.4 回答者： tom04 回答日時： 2019/07/09 17:55

こんにちは！

一案です。
↓の画像のようにB列「名前」？を塗りつぶしたい色にしておきます。
そうした上での一例です。

Sub Sample1()
　Dim i As Long, cnt As Long
　Dim myRow As Long, myCol As Long
　Dim lastCol As Long

　　lastCol = Cells(2, Columns.Count).End(xlToLeft).Column
　　　Range(Columns("F"), Columns(lastCol)).Interior.ColorIndex = xlNone
　　　　myRow = 2
　　　　For i = 3 To Cells(Rows.Count, "B").End(xlUp).Row
　　　　　myCol = 5
　　　　　　If Cells(i, "C") > 0 Then
　　　　　　　Do Until cnt = Cells(i, "C")
　　　　　　　　cnt = cnt + 1
　　　　　　　　　If cnt Mod Cells(i, "D") = 1 Then
　　　　　　　　　　myRow = myRow + 1
　　　　　　　　　　myCol = 5
　　　　　　　　　End If
　　　　　　　　myCol = myCol + 1
　　　　　　　　　Cells(myRow, myCol).Interior.Color = Cells(i, "B").Font.Color
　　　　　　　Loop
　　　　　　End If
　　　　　　　cnt = 0
　　　　Next i
End Sub

※　色によっては判別しにくいコトもあるかもしれません。
その場合は使っていない列のセルを塗りつぶし、
その色を利用した方が良いかもしれませんね。m(_ _)m

No.3 回答者： taku-9023.ham 回答日時： 2019/07/09 15:42

＜設定の仕方＞

　　A　　 B　　 C D .... ※下の方にどんどん追加していってください。
1 name 数量 MAX　　　　　　　ただし、NAME_NUM　, Colors の値を変更すること。
　　　　　　　　　　　　　　　　　　　　色を塗ったあと、消すとき用にDePaintCell() を作りました。
2　 a 12 10　　　　　　　　いらなかったら消しといてください。

3 b 8 12　　　　　　　　セルの色が気に入らなかったらネットでInterior.ColorIndexについて
　　　　　　　　　　　　　　　　　　　　調べて、変更、追加してください。
4 c 20 8
. <Colorsの変更の仕方>
. Colors = Array(3, 5, 6) <-ここを
.　　　　　　　　　　　　　　　　　　　　Colors = Array(3, 5, 6 , 12, 35) のようにする。
　　　　　　　　　　　　　　　　　　　　(１色目、２色目、３色目、４色目...)となっています。

No.2 回答者： taku-9023.ham 回答日時： 2019/07/09 15:32

Option Explicit

Sub DePaintCell()
Const START_COLUMN As String = "E", START_ROW As Integer = 2 '?F?h??J?n??u
Const END_COLUMN As String = "P", END_ROW As Integer = 100

Range(START_COLUMN & START_ROW & ":" & END_COLUMN & END_ROW).Interior.ColorIndex = 0
End Sub

Sub PaintCell()
Const NAME_NUM As Integer = 3 '種類の数
Dim Colors(): Colors = Array(3, 5, 6)
Dim value(2, NAME_NUM - 1)
Dim i As Integer, j As Integer

For i = 0 To 2
For j = 0 To NAME_NUM - 1
value(i, j) = Cells(j + 2, i + 1)
Next
Next

Const START_COLUMN As String = "E", START_ROW As Integer = 2 '色塗り開始位置
Const END_COLUMN As String = "P"
Dim now_row As Integer
now_row = START_ROW

For i = 0 To NAME_NUM - 1
Do
For j = Rows_address(START_COLUMN) To Rows_address(END_COLUMN)
Cells(now_row, j).Interior.ColorIndex = Colors(i)
value(1, i) = value(1, i) - 1
If value(1, i) <= 0 Then
now_row = now_row + 1
Exit Do
ElseIf j - Rows_address(START_COLUMN) + 1 >= value(2, i) Then
now_row = now_row + 1
Exit For
End If
Next
Loop While True
Next
End Sub

Private Function Rows_address(str As String) As Integer 'A->1, AB->28, BR->70
Dim i As Integer

For i = 1 To Len(str)
Rows_address = Rows_address + (Asc(UCase(Mid(str, i, 1))) - 64) * 26 ^ (Len(str) - i)
Next

End Function

作れましたのでどうぞ。
追加等あれば、また言ってください。

No.1 回答者： chonami 回答日時： 2019/07/09 15:31

つまり、MAX値とあるのはいわゆるロット数で、数量がロット数を超えている場合は次の行（2ロット目）にはみ出て塗りつぶしをしてほしいということですかね。

商品が変わる場合は、前の商品の塗りつぶしの次の行から塗って欲しいと。

>※写真とセルが少し違いますがご了承下さい
サンプルを出すなら、説明と整合させるのは最低限の礼儀かと思います。
どっちかに合わせて回答を作っても実際の配置と違ってて、うまく変更できませ～ん、と帰ってきて時間の無駄になることもあります。

この回答へのお礼

サンプルについてはごもっともです。
言い訳になりますが、説明文だけでいけるか不安で写真を貼り付けたが、セルがずれてるままでした。

お礼日時：2019/07/09 19:02