![](http://oshiete.xgoo.jp/images/v2/pc/qa/question_title.png?e8efa67)
Sheet1のA列に個人番号、B列に氏名が入っています。C列からG列までに1から50までの整数が入っている表があります。1行目がタイトル行で、2行目以下にデータが入っています。
ただ条件があって、例えば、ある人のC列からG列までのどこかに1が入っている場合は、13, 27, 41がその他の列に入っている場合、エラーとしてわかる(該当セルに色を塗る)ようにしたいのですが、どうしたらいいでしょうか?
実際は上記のような条件がいくつもあるのでVBAを用いてするしかないと思うのですが、やり方が思いつきません。If ~ thenでひとつひとつチェックする以外に効率的な方法があれば教えてください。
Excel2007を使っています。
No.6ベストアンサー
- 回答日時:
「そのほか」がどれだけあるのか解らないので、別シートにそのリストを作る前提でサンプルマクロ作ってみました。
#かなり強引なマクロですが……
「ErChk」と言うシートにエラーの条件を入力しておくものとします。
「ErChk」シートの書式は添付画像を参照してください。
Sheet1に入力後、以下のマクロを起動するとエラー箇所を塗りつぶします。
Sub Sample()
Worksheets("Sheet1").Select
Columns("C:G").Interior.Pattern = xlNone
nMax = Cells(Rows.Count, 2).End(xlUp).Row
For i = 2 To nMax '氏名が入っている最後の行まで
'定義シート「ErChk」にエラーチェックの定義が入っていること
For j = 2 To Worksheets("ErChk").Cells(Rows.Count, 1).End(xlUp).Row
If WorksheetFunction.CountIf(Range(Cells(i, 3), Cells(i, 7)), Worksheets("ErChk").Cells(j, 1)) > 0 Then
For k = 2 To 4 'エラーをチェックするのはErChk B:D列の3種類の値
nChk = Worksheets("ErChk").Cells(j, k)
For l = 3 To 7 'Sheet1のC~G列が塗りつぶし対象
If Cells(i, l) = nChk Then
Cells(i, l).Interior.ThemeColor = xlThemeColorAccent6
End If
Next l
Next k
End If
Next j
Next i
End Sub
![「入力したデータのエラーチェックをしたいで」の回答画像6](http://oshiete.xgoo.jp/_/bucket/oshietegoo/images/media/f/1241782_5497e1aa1621a/M.jpg)
再度の回答ありがとうございます。画像があるのでとてもわかりやすかったです。
> #かなり強引なマクロですが……
いえいえ、私のようなあまり知識のないものにとっては、これぐらいのマクロの方がずっとわかりやすいです。教えていただいたVBAのコードは理解できました。これをベースにして、ちょっと変更するだけで、エラーチェックすることができました。
1分1秒を争って仕事をしているわけではないので、強引でも(と言われていますが、私からしたら洗練されたと言いたいぐらいです)わかりやすいマクロで助かりました。これで仕事が大幅にはかどりそうです。(^_^)
ありがとうございました。m(__)m
No.11
- 回答日時:
えーと・・・4番でお邪魔した者です^^;
皆さまの回答を拝見していて・・質問文を読み返して・・・
ようやく気付いたんですが・・・
これは「入力されているデータに対して」行う処理なのですね^^;;
私、勘違いして「新しく入力されたデータに対して」の処理を考えてました^^;;
なので、「入力されているデータに対する処理」バージョンを、今さらですが。
Sub test2()
Dim TRange As Object, TCell As Object
Dim myErr As Variant
Dim TRow As Long, i As Integer, j As Integer
Application.ScreenUpdating = False
Columns("C:G").Interior.Pattern = xlNone
For TRow = 2 To Range("B" & Rows.Count).End(xlUp).Row
Set TRange = Range("C" & TRow & ":G" & TRow)
For i = 2 To Range("J" & Rows.Count).End(xlUp).Row
Set myErr = Range("J" & i & ":M" & i)
Set TCell = TRange.Find(What:=myErr(1), LookAt:=xlWhole)
If Not TCell Is Nothing Then
For j = 2 To 4
For Each myCell In TRange
If myCell = myErr(j) Then
myCell.Interior.Color = RGB(0, 255, 255)
End If
Next
Next j
End If
Set myErr = Nothing:Set TCell = Nothing
Next i
Next TRow
Set TRange = Nothing: Set TCell = Nothing: Set myErr = Nothing
Application.ScreenUpdating = True
Msgbox "処理完了"
End Sub
データ件数(行数)が1000行(一郎~千郎まで)、対象が5列(正味5000セル)、
条件を7種類用意し、1/3~半分(2000~2500セル)を塗り潰す感じのテストデータを
添付図のように「条件を列記した表」と比較して、色を付けていきます。
(テストの都合上、数値の範囲を1~20までとしてランダムに打っていますので
数字に重複が有ったりしますが、見逃してくださいませ。)
配列の考え方が入るので若干ややこしいですが、読み解くと意外と簡単です。
ちなみに(私のパソコンで)0.8~1秒で処理が終わります。
![「入力したデータのエラーチェックをしたいで」の回答画像11](http://oshiete.xgoo.jp/_/bucket/oshietegoo/images/media/7/1229456_5497e1abea940/M.jpg)
再度の回答、ありがとうございました。
とりあえず、他の方の回答をもとに処理はできるようになったのですが、
教えていただいたVBAや配列も勉強してみようと思います。
いろいろありがとうございました。
No.10
- 回答日時:
性能対策版(ハイライト処理簡略)
1万行全部にトリガをセットしても10秒かかりません。
Option Explicit
Sub HighLightCells()
Const xName = "Sheet1" 'シート名
Const xHeads = 1 'ヘッダ行数
Const xColumn = 3 'チェックする範囲From
Const xColumn2 = 7 'チェックする範囲To
Const xKeyValue = 1 'マークする条件値
'Const xDoBonValue = "13,47,99" 'マークする値
Const xBlack = 1
Const xWhite = 2
Const xBlue = 5
Const xYellow = 6
Dim kk As Long
Dim nn As Long
Dim mm As Long
Dim xSheet As Worksheet
Dim xLast As Long
Dim xDoBon() As Variant
Dim xMatch As Boolean
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'xDoBon = Split(xDoBonValue, ",")
'xDoBon = Array(14, 27, 41, 1, 55, 77, 99)
xDoBon = Array(14, 27, 41) 'マークする値
Set xSheet = Sheets(xName)
xSheet.Range(xSheet.Columns(xColumn), xSheet.Columns(xColumn2)).Interior.Pattern = xlNone
xLast = xSheet.Cells(Rows.Count, "A").End(xlUp).Row
For nn = 1 + xHeads To xLast
xMatch = (WorksheetFunction.CountIf(xSheet.Range(xSheet.Cells(nn, xColumn), xSheet.Cells(nn, xColumn2)), xKeyValue) > 0)
If (xMatch) Then
For kk = xColumn To xColumn2
For mm = 0 To UBound(xDoBon)
If (xSheet.Cells(nn, kk) = xDoBon(mm)) Then
'HighLight
xSheet.Cells(nn, kk).Interior.ColorIndex = xYellow
Exit For
End If
Next mm
Next kk
End If
Next nn
Application.CutCopyMode = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
何度も回答いただきありがとうございました。
他の方の回答をもとに何とか処理はできるようになりました。
教えていただいた回答のVBAは私にとってはレベルが高くて、
まだ解読できていないのですが、この際、勉強してみようと思います。
いろいろありがとうございました。
No.9
- 回答日時:
マークしたい値を変更するときは、
Const xDoBonValue = "13,47,99" 'マークする値
ではなく、コードの中に隠れているこちらを適当に変えてみてオクレヤス、、、
xDoBon = Array(14, 27, 41)
1万魚で1分もかかりマスタ、反省、、、
No.8
- 回答日時:
No.7です。
お礼欄の二つの件について・・・
前回のコードに応用を効かせる行を載せておきます。
(1)条件が現在7つぐらいあり、まだこの先増える可能性もありますし
は
>myArray = Array(13, 27, 41)
の中に追加していきます。
仮に 13・27.41.48・49 がエラーと判断する場合は
>myArray = Array(13, 27, 41, 48, 49)
のようにカンマで区切って追加してください。
今回は数値ですので、ダブルクォーテーションは必要ありませんが、
文字列の場合は
>myArray = Array("あ", "い", "う")
のようにします。
(2)問題は、最初にエラーになる決まりが決まっているのではなく、後から決まったり
は
>Range(wS1.Cells(2, 1), wS1.Cells(i, 1)).Formula = "=IF(COUNTIF(D2:H2,1),1,"""")"
の行で調整します。
上記はCOUNTIF関数そのものですので、
D列~H列に「1」があればA列に「1」を表示、なければ「空白」に!というコトです。
(A列を挿入していますので、元データが右へ1列ずつずれ、上記数式となります)
仮にエラーになる値「4」が範囲内にあれば
>Range(wS1.Cells(2, 1), wS1.Cells(i, 1)).Formula = "=IF(COUNTIF(D2:H2,4),1,"""")"
に変更します。
あとはA列が「1」でオートフィルタをかけ、Sheet2にコピーする方法は変更なしで大丈夫です。
上記二点の訂正で、おそらく条件が変わっても対応できると思います。
(マクロ実行前に、塗りつぶしをすべて「なし」にしておく必要があります)
こんなんでお役に立ちますかね?m(_ _)m
お礼がおそくなってすみません。
別の方の回答をもとになんとか処理できたのですが、お示しいただいた回答の解読はまだできていません。
特にarrayの使い方がよくわかっていないので、この際、勉強したいと思います。
いろいろありがとうございました。
No.7
- 回答日時:
こんばんは!
データ量が多い場合、For~Nextで関係のない行もLoopさせても
無駄に時間を要するだけですので、
オートフィルタで「1」がある行だけを別Sheetに抽出し、そのデータ内でloopさせる方法はどうでしょうか?
その一例です。
作業用のSheetとしてSheet2を使用していますので、Sheet2はまったく使用していない!という前提です。
Sub test()
Dim i As Long
Dim j As Long
Dim k As Long
Dim mG As Long
Dim nG As Long
Dim wS1 As Worksheet
Dim wS2 As Worksheet
Dim myArray As Variant
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
myArray = Array(13, 27, 41)
i = wS1.Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
wS1.Columns(1).Insert
Range(wS1.Cells(2, 1), wS1.Cells(i, 1)).Formula = "=IF(COUNTIF(D2:H2,1),1,"""")"
wS1.Cells(1, 1).CurrentRegion.AutoFilter field:=1, Criteria1:="1"
Range(wS1.Columns(1), wS1.Columns(8)).Copy wS2.Cells(1, 1)
For j = 4 To 8
For nG = 2 To wS2.Cells(Rows.Count, 1).End(xlUp).Row
For k = 0 To UBound(myArray)
If wS2.Cells(nG, j) = myArray(k) Then
mG = WorksheetFunction.Match(wS2.Cells(nG, 2), Columns(2), False)
wS1.Cells(mG, j).Interior.ColorIndex = 6 '←黄色にしています。
End If
Next k
Next nG
Next j
wS1.Columns(1).Delete
wS2.Cells.Clear
wS1.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub
こんな感じではどうでしょうか?m(_ _)m
回答ありがとうございます。
条件が現在7つぐらいあり、まだこの先増える可能性もありますし、オートフィルタをVBAで操作したことがないので、最悪、マクロではなくオートフィルタを使って手作業でやろうかと思っていたところでした。
問題は、最初にエラーになる決まりが決まっているのではなく、後から決まったり、追加されたりすることがあるので、手作業だと全部が確定してからでないと何回もやり直しをする必要がありそうなことでした。
ご呈示いただいたVBAのコードがまだ読み解けていないのですが、頑張ってこの週末には読み解こうと思います。
ありがとうございました。
No.5
- 回答日時:
Option Explicit
Sub HighLightCells()
Const xName = "Sheet1"
Const xHeads = 1
Const xKeyValue = 1 'マークする条件値
Const xDoBonValue = "13,47,99" 'マークする値
Const xColumn = 3 'チェックする範囲From
Const xColumn2 = 7 'チェックする範囲To
Const xBlack = 1
Const xWhite = 2
Const xBlue = 5
Const xYellow = 6
Dim xSheet As Worksheet
Dim xLast As Long
Dim xDoBon() As Variant
Dim xMatch As Boolean
Dim kk As Long
Dim nn As Long
Dim mm As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'xDoBon = Split(xDoBonValue, ",")
xDoBon = Array(13, 47, 99)
Set xSheet = Sheets(xName)
xLast = xSheet.UsedRange.Rows.Count
For nn = 1 + xHeads To xLast
For kk = xColumn To xColumn2
'Reset
xSheet.Cells(nn, kk).Font.Bold = False
xSheet.Cells(nn, kk).Font.ColorIndex = xBlack
xSheet.Cells(nn, kk).Interior.ColorIndex = xWhite
Next kk
Next nn
xLast = xSheet.Cells(Rows.Count, "A").End(xlUp).Row
For nn = 1 + xHeads To xLast
xMatch = False
For kk = xColumn To xColumn2
If (xSheet.Cells(nn, kk) = xKeyValue) Then
xMatch = True
Exit For
End If
Next kk
If (xMatch) Then
For kk = xColumn To xColumn2
For mm = 0 To UBound(xDoBon)
If (xSheet.Cells(nn, kk) = xDoBon(mm)) Then
'HighLight
xSheet.Cells(nn, kk).Font.Bold = True
xSheet.Cells(nn, kk).Font.ColorIndex = xYellow
xSheet.Cells(nn, kk).Interior.ColorIndex = xBlue
Exit For
End If
Next mm
Next kk
End If
Next nn
Application.CutCopyMode = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
回答ありがとうございます。
今ちょっとまた別の仕事が急に入ってきているので、教えていただいたVBAのコードを読み解く時間が取れないのですが、この週末を使って、何とか頑張って読み解こうと思います。
とりあえず、お礼のみですが、失礼します。
No.4
- 回答日時:
急ごしらえで書き方は雑ですが。
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRange As Object, myCell As Range
Dim myRow As Long, i As Long
myRow = Target.Row
For i = 1 To 50
With Range(Cells(myRow, 3), Cells(myRow, 7))
.FormatConditions.Delete
Set myRange = .Find(What:="1", LookAt:=xlWhole)
If Not myRange Is Nothing Then
For Each myCell In Range(Cells(myRow, 3), Cells(myRow, 7))
If myCell = 14 Or myCell = 27 Or myCell = 41 Then
myCell.Interior.Color = RGB(255, 0, 0)
Else
myCell.Interior.ColorIndex = xlNone
End If
Next
Else
For Each myCell In Range(Cells(myRow, 3), Cells(myRow, 7))
myCell.Interior.ColorIndex = xlNone
Next
End If
End With
Next
End Sub
こんな感じでセル5個に対して「条件判断→書式設定」を
> 1から50までの整数
との事なので、50回繰り返し、正味で250回の書式設定を繰り返しましたが、
(こんな雑な書き方でも)0.1秒かからずに終了しました。
これを効率的と見るか、非効率的と見るかの判断はお任せします。
これに例えば
> ある人のC列からG列までのどこかに1が入っている場合は、13, 27, 41がその他の列に入っている場合、エラー
> ある人のC列からG列まで2が入力されている場合は、その他のセルには7,19,47はエラー
この「1・2」が同時に発生するケースはどうするのか?などの条件が入ると
コードももう少し捻る必要がありそうですが、
それがないのであれば上記のコードの繰り返しの中で条件設定していけば
気になるほどの時間はかからないはずですよ。
とりあえず、
> If ~ thenでひとつひとつチェックする以外に効率的な方法があれば
ご自身で検証した「非効率と判断したIf~Thenを使ったコード」があればご提示くださいませ。
回答ありがとうございます。
> Set myRange = .Find(What:="1", LookAt:=xlWhole)
たぶん私が探していたのはこの部分だと思います。
こういうやり方がわからないので、If ~ thenで探していこうと思っていました。
> この「1・2」が同時に発生するケースはどうするのか?
エラーが重複しても区別せずにエラーでかまいません。
>> If ~ thenでひとつひとつチェックする以外に効率的な方法があれば
> ご自身で検証した「非効率と判断したIf~Thenを使ったコード」があればご提示くださいませ。
効率的な方法というよりも、ひとつひとつのセルをIf ~ thenでチェックするコードをずっと書いていくのが非効率というか、大変だと思った次第です。
ありがとうござました。少しやり方の道筋が見えてきました。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Excel(エクセル) 【条件付き書式】countifsで複数条件を満たしたセルを赤くする方法 2 2023/02/09 23:53
- Visual Basic(VBA) 列と行の名前(重複あり)が交差するセルに、データを入力したい 2 2022/06/25 22:42
- Visual Basic(VBA) Changeイベントで複数セルへの貼り付けおよび値削除時に1個目のセルのみエラーになる 3 2022/12/21 09:07
- Visual Basic(VBA) 3つのプロシージャをまとめたら実行時エラー発生で対応不能 6 2022/05/17 01:47
- Visual Basic(VBA) VBA 改行コードの取り方 1 2022/03/22 14:14
- Visual Basic(VBA) ファイル全てを .xlsm に変更したところ、プログラムが途中で落ちてしまっています 17 2022/12/07 12:03
- Visual Basic(VBA) 【VBA】データを入力後に,同一シート内に履歴として転記するVBAコードを教えていただきたいです。 3 2022/11/16 01:37
- Visual Basic(VBA) vba 等間隔の列に対しての計算 6 2022/05/17 20:15
- Visual Basic(VBA) 列と行の名前(重複あり)が交差するセルに、データを入力したい 3 2022/06/12 11:17
- Visual Basic(VBA) VBAで、1つのエクセルで、2つのシートからもう1つのシートに条件のある転記コードを教えてください。 1 2023/03/16 18:07
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
Excel2017 フィルタ昇順並びがA...
-
エクセルで行の高さ及び列幅の...
-
オートフィルタ後のデータから...
-
Excelで並び替え後にア行...
-
EXCELで日付を比べ3か月以内の...
-
列と行の名前(重複あり)が交...
-
エクセルの時刻のカウントが出...
-
VBA 複数行の検索及び抽出
-
【Excel VBA】指定した行の最大...
-
基準日以前のデータを範囲を指...
-
文字列を比較し、相違するフォ...
-
【Excel】数式の参照範囲を可変...
-
複数回答のクロス集計の方法
-
EXCEL 最終行のデータを他のセ...
-
マクロで行の高さを設定したい
-
入力したデータのエラーチェッ...
-
エクセルで2つの郵便番号を比較...
-
続質問 エクセルVBAで、行コピ...
-
急ぎ!色のついたセルを非表示...
-
エクセル関数のSUMPRODUCTにつ...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Excel2017 フィルタ昇順並びがA...
-
エクセルで行の高さ及び列幅の...
-
【Excel VBA】指定した行の最大...
-
Excelで並び替え後にア行...
-
急ぎ!色のついたセルを非表示...
-
エクセルの時刻のカウントが出...
-
オートフィルタ後のデータから...
-
基準日以前のデータを範囲を指...
-
EXCEL 最終行のデータを他のセ...
-
マクロで行の高さを設定したい
-
EXCELで日付を比べ3か月以内の...
-
エクセル関数について
-
文字列を比較し、相違するフォ...
-
エクセル VBA 行間隔を飛ばした...
-
Excel VBAでセルのクリアが出来...
-
【Excel】数式の参照範囲を可変...
-
excel / ピポッド 日数を出したい
-
時間の重複チェック
-
検索条件に合うセルの個数を数...
-
複数回答のクロス集計の方法
おすすめ情報