マクロを使って文字が入力されたセル数を数える

質問

マクロを用いて、文字が入力されたセル数をカウントしたいと考えていますがうまくいかず悩んでおります．．．

具体的には、セルB1からB1000にデータが入力された場合、左隣のA列に1から番号を付したいと考えています．
B列が空白のままの行は、A列も空白にしておきたいです．
（セルB1からB1000まで全てにデータが入力された場合、A1からA1000には1から1000までの番号が入る）

また、A列に付された番号を判断し、100番毎にA列からE列までセル背景を色分けしていきたいと考えています．
（B列が空白ならxlNoneでその行は無色のままにしたい）

セル背景の色分けだけであればうまくいったのですが、B列の入力状況により自動でA列に番号（数字）を変化させたら思い通りに動かず困っています．

ご教示、宜しくお願いします．

回答No.2

_Kyle · ベストアンサー

#1です。

補足と参考画像を拝見しましたが「質問者さんがなさりたいこと」を
私がきちんと理解できているのか自信がなくなってしまいました(^^;;;

一応下記のように検討してみましたが、
実際の運用がどのようなものであるのか、今一つイメージできていないので
もしかすると見当外れな内容かもしれません。

なお、当初の質問内容とはかなり要件が変わってしまいましたので
補足の課題について新たな回答者が現れる可能性は低いかもしれません。
下記の内容で解決しない場合は、ココはいったん閉じて、
あらためて質問を立てられた方がよろしいかと。
（[その他(Windows)]カテゴリはちょっとさびれているので、
　[MS Office]とか[Office系ソフト]あたりをオススメします。）
------------------------------------------------
セルが変更されたときの処理を
次のように切り分けて考ることにします。

１．G1:G6　が変化したとき
　Ａ．G1:G6のセルの背景色を変える
　Ｃ．(色の並びが変わるので)A:E列の背景色を更新する
２．H1:H6　が変化したとき
　Ｃ．(群の区切が変わるので)A:E列の背景色を更新する
３．B1:B30　が変化したとき
　Ｂ．(B列のデータが変わるので)A列の値を更新する
　Ｃ．(A列の並びが変わるので)A:E列の背景色を更新する

●コレは該当シートのシートモジュールに記述
'======================↓　ココカラ　↓======================
Private Sub Worksheet_Change(ByVal Target As Range)
　Application.EnableEvents = False
　If Not Intersect(Target, Range("G1:G6")) Is Nothing Then
　　Call SampleA
　　Call SampleC(1)
　End If
　If Not Intersect(Target, Range("H1:H6")) Is Nothing Then
　　Call SampleC(1)
　End If
　If Not Intersect(Target, Range("B1:B30")) Is Nothing Then
　　Call SampleB
　　Call SampleC(Intersect(Target, Range("B1:B30")).Row)
　End If
　Application.EnableEvents = True
End Sub
'======================↑　ココマデ　↑======================
※Elseifで並べると「G:H列を同時に変更した」といった場合に困るので、
　個別にIFを立てて繰り返し判定します。

●コチラは標準モジュールに記述
'======================↓　ココカラ　↓======================
Sub SampleA() '処理Ａ
　Dim Rng As Range
　Dim i As Long
　For Each Rng In Range("G1:G6")
　　Select Case Rng.Value
　　　Case "北海道": i = 38
　　　Case "宮城": i = 40
　　　Case "東京": i = 36
　　　Case "大阪": i = 35
　　　Case "福岡": i = 34
　　　Case "沖縄": i = 37
　　　Case Else: i = xlNone
　　End Select
　　Rng.Interior.ColorIndex = i
　Next Rng
End Sub
'--------------------------------
Sub SampleB() '処理Ｂ
　Dim caAry As Variant
　Dim cbAry As Variant
　Dim r　　 As Long
　Dim c　　 As Long
　ReDim caAry(1 To 30, 1 To 1)
　cbAry = Range("B1:B30").Value
　For r = 1 To 30
　　If cbAry(r, 1) <> "" Then
　　　c = c + 1
　　　caAry(r, 1) = c
　　End If
　Next r
　Range("A1:A30").Value = caAry
End Sub
'--------------------------------
Sub SampleC(ByVal r As Long) '処理Ｃ
　Dim clAry() As Long
　Dim dlAry　 As Variant
　Dim caAry　 As Variant
　Dim i　　　 As Long
On Error GoTo ErrorHandler
　Application.ScreenUpdating = False
　ReDim clAry(1 To 6)
　For i = 1 To 6
　　clAry(i) = Cells(i, "G").Interior.ColorIndex
　Next i
　dlAry = Range("H1:H6").Value
　caAry = Range("A1:A30").Value
　Range(Cells(r, "A"), Range("E30")).Interior.ColorIndex = xlNone
　For r = r To 30
　　If caAry(r, 1) <> "" Then
　　　Range("A:E").Rows(r).Interior.ColorIndex = _
　　　　clAry(WorksheetFunction.Match(caAry(r, 1), dlAry, 1))
　　End If
　Next r
　Application.ScreenUpdating = True
　Exit Sub
ErrorHandler:
　Application.EnableEvents = True
　Application.ScreenUpdating = True
End Sub
'======================↑　ココマデ　↑======================
※「補足」のコードに対応する部分(SampleA)をだいぶ削っていますが、
主に投稿上の都合によるもので「このように書くベシ！」という意味ではありません。
ただ、対象が6セル程度の場合は、毎回全部直しても大きな負担ではありませんし
差分のみ直すよりも堅牢ではないかと思います。

以上ご参考まで。長乱文・乱コード陳謝

お礼

_Kyleさん

先にご回答いただいた内容とあわせ、追加でご指南いただいた内容は
真に私のやりたかったことと合致しております。

質問文が明確でなかったにも関わらず、迅速かつ的確なご回答に大変
助かりました。
本当にありがとうございます。

また、当方未熟故、当サイトの利用に関してのアドバイスまでいただき
真にありがとうございました。

回答No.1

_Kyle

こういうことでしょうか？

●B列の入力後、一括して処理する場合

できるだけぢみ～に書いてみました。
標準モジュールに記述して手動で起動してください。

'==================↓　ココカラ　↓==================
Sub Sample090706()
　Dim clAry As Variant　'色配列
　Dim r　　 As Long　　 '行カウンタ
　Dim c　　 As Long　　 '値カウンタ
　Dim g　　 As Long　　 '群カウンタ
　'背景に使う色を10種類指定
　clAry = Array(38, 40, 36, 35, 34, 37, 39, 33, 8, 4)
　'対象範囲の背景色を初期化
　Range("A1:E1000").Interior.ColorIndex = xlNone
　'A列の値を初期化
　Range("A1:A1000").ClearContents
　'1行目から1000行目まで回す
　For r = 1 To 1000
　　'B列の値の有無をチェック
　　If Cells(r, "B") <> "" Then
　　　'値カウンタをカウントアップ
　　　c = c + 1
　　　'A列に値カウントをセット
　　　Cells(r, "A").Value = c
　　　'当該行のA:E列を現在の群に応じた色で塗潰す
　　　Range("A:E").Rows(r).Interior.ColorIndex = clAry(g)
　　　'区切であれば群カウンタをカウントアップ
　　　If (c Mod 100) = 0 Then g = g + 1
　　End If
　Next r
End Sub
'==================↑　ココマデ　↑==================

*********************************************************

●B列の値を追加・削除したときに随時更新する場合

下記はイベントドリブンマクロです。
当該シートのシートモジュールに記述してください。

高速化のため「変更があった場所から下方」についてのみ処理します。
結果がおかしい場合はB1セルの値を入れ直してみてください。

・サンプルコードなのであまり凝ったことはしたくない
・ストレスなく連続して入力できる程度には速くしたい
・でも変更直前のカウンタや色は信用できないかもしれない
という綱引きで、我ながらかなりグダグダなコードになっています^^;;;

なお、参考動画は【5番毎】にカスタマイズしたバージョンの映像です。

'==================↓　ココカラ　↓==================
Private Sub Worksheet_Change(ByVal Target As Range)
　Dim myRng As Range
　Dim clAry As Variant
　Dim ctAry As Variant
　Dim r　　 As Long
　Dim c　　 As Long
　Dim g　　 As Long
　Set myRng = Intersect(Range("B1:B1000"), Target)
　If myRng Is Nothing Then Exit Sub
　With Application
　　.Calculation = xlCalculationManual
　　.ScreenUpdating = False
　　.EnableEvents = False
　End With
　clAry = Array(38, 40, 36, 35, 34, 37, 39, 33, 8, 4)
　r = myRng.Row
　If r = 1 Then
　　c = 0
　Else
　　c = WorksheetFunction.Max(Range("A1").Resize(r - 1))
　End If
　g = Int(c / 100)
　Range(Cells(r, "A"), Range("E1000")).Interior.ColorIndex = xlNone
　Range(Cells(r, "A"), Range("A1000")).ClearContents
　ctAry = Range("A1:A1000").Value
　For r = r To 1000
　　If Cells(r, "B") <> "" Then
　　　c = c + 1
　　　ctAry(r, 1) = c
　　　Range("A:E").Rows(r).Interior.ColorIndex = clAry(g)
　　　If (c Mod 100) = 0 Then g = g + 1
　　End If
　Next r
　Range("A1:A1000").Value = ctAry
　With Application
　　.Calculation = xlCalculationAutomatic
　　.ScreenUpdating = True
　　.EnableEvents = True
　End With
End Sub
'==================↑　ココマデ　↑==================

いずれもExcel2003で動作確認。
以上ご参考まで。長乱文・乱コード陳謝。

補足

_Kyleさん

ありがとうございます！
先に質問した件はご指南いただいた動画のとおりです！
やりたかったことがほぼできました！

追加の質問で恐縮ですが、別シートでは100行毎の色分けでなく、任意の範囲で色分けをしたいと考えています。
（画像サンプル）

具体的には、以下のように考えています。
・G列に入力するデータ群は、プルダウンより下記を選択。
　（→北海道、宮城、東京、大阪、福岡、沖縄）

・H列およびJ列で指定範囲を任意で変更させる。
　（自動カウントされたA列の数字を判定し、A列からE列の色を変化させる）

大変恐縮ですが、再度ご指南いただきたく宜しくお願いします。

なお、現在sheet2には下記のようにマクロを組もうとしております。

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("G1:G6")) Is Nothing Then

Dim Rng As Range
Dim i As Long
For Each Rng In Target

With Rng
Select Case .Value

Case "北海道": i = 38
Case "宮城": i = 40
Case "東京": i = 36
Case "大阪": i = 35
Case "福岡": i = 34
Case "沖縄": i = 37
Case Else: i = xlNone

End Select
.Interior.ColorIndex = i

End With

Next
Set Rng = Nothing

End If

'===============================================================
'ここに、
'If Not Intersect(Target, Range("B1:B30")) Is Nothing Then　でB列の変化に
'応じて動くマクロを組みたかったのですが、うまくいきませんでした．．．
'===============================================================

End Sub