SpecialCells(xlCellTypeVisible)メソッドのバグ？を回避する（Tips-16）
今回は、可視セルのみを取得するSpecialCells(xlCellTypeVisible)メソッド使用時のバグと、バクの回避方法について考えてみたいと思います。
VBA界では有名？なのかどうか分かりませんが、非表示の行または列がシート内に1以上ある状態で、単一セル対してSpecialCells(xlCellTypeVisible)メソッドを使用すると謎のバグが発生するようです。
下のコードで試してみたいと思います。（単純に、選択している可視セルに絵文字を入力するだけのものです）
Sub test()
Dim myRange As Range
For Each myRange In Selection.SpecialCells(xlCellTypeVisible)
myRange.Value = "(＠_＠;)"
DoEvents
Next myRange
End Sub
このコードを下のシートのB2セル（単一セル）で実行してみます。色付きの行および列は実験で表示⇔非表示を切り替える予定の箇所です。
まず、バグが発生しない例からです。
非表示の行または列が1つもないシートで、testコードを実行。
処理がB2セルのみに行われます。（予定どおりの結果）
以降、バグが発生する例です。
行番号5を非表示にして、testコードを実行。
処理がB2セルのみではなく、シート内のすべてのセルに行われ、応答なしになります。
列番号Eを非表示にし、testコードを実行。
処理がB2セルのみではなく、Eの左側すべてに行われ、応答なしになります。
行番号5と列番号Eを非表示にし、testコードを実行。
処理がB2セルのみではなく、5の上側とEの左側のすべてに行われ、応答なしになります。
なお、非表示の有無に関らず、2以上のセルを選択した状態で実行すれば、上のようなバグは発生しません。
testコードのようにユーザーが範囲選択してから実行するコードを、うっかり単一セルで実行してしまうと前述のバグに見舞われます。
かといって、シート内に非表示があるかないか、コード内にSpecialCells(xlCellTypeVisible)メソッドが使われているかどうか、を注意し、そのうえでユーザーが単一セルでの実行可否を判断するのは本質の安全化ではないですよね。
ということで、ユーザーに頼らないバグ回避方法（暫定）を考えてみます。testコードの場合であれば、下の赤字箇所を追記すれば、ユーザーがぼんやりしていても回避できます。
Sub testバグ回避版()
Dim myRange As Range
If Selection.Count > 1 Then
For Each myRange In Selection.SpecialCells(xlCellTypeVisible)
myRange.Value = "(＠_＠;)"
DoEvents
Next myRange
Else
ActiveCell.Value = "(＠_＠;)"
End If
End Subドヤ顔でいうほどのことではないですが、
- 選択範囲が複数であれば、SpecialCells(xlCellTypeVisible)メソッドを使う処理
- 選択範囲が単一であれば、SpecialCells(xlCellTypeVisible)メソッドを使わない処理
に分岐させているだけです。
オートフィルタで絞り込んで印刷（を抽出条件の分だけ繰り返す）
今回はオートフィルタで絞り込んでから印刷する、という作業を自動化してみたいと思います。
こんなイメージ。
この表の商品の列で、
というような繰り返しを自動化します。
さっそくコードを作ってみました。
コード１
Sub 選択範囲のデータを改行区切りでクリップボードに格納() Dim myRange As Range Dim V As String Dim myLib As Object Set myLib = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '参照設定なしでDataObjectのインスタンスを生成する If Selection.Count > 1 Then For Each myRange In Selection.SpecialCells(xlCellTypeVisible) '可視セルのみに処理を行う If myRange.Address = myRange.MergeArea(1).Address Then '結合セルの場合は左上の値のみ取り出す V = V & myRange.Value & vbCrLf End If Next myRange V = Left(V, Len(V) - 2) '最終行の改行区切りを取り除く（CrLfは2文字） Else V = ActiveCell.Value End If myLib.SetText V '変数の値をDataObjectに格納する myLib.PutInClipboard 'DataObjectのデータをクリップボードに格納する End Sub
コード２
Sub 絞り込んで印刷を繰り返す() 'クリップボードの文字列を配列に取り込み、配列の内容で順番に絞込みします '現在選択しているセルの列をフィルタリングします 'シートにオートフィルターがない場合は、そのセルを含むアクティブセル領域をオートフィルターに設定した上で絞込みします '現在の印刷設定で印刷します Dim XS As Integer Dim XP As Integer Dim YS As Long Dim YE As Long Dim V As Variant Dim i As Integer Dim 可視セル数 As Long Dim myLib As Object Set myLib = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '参照設定なしでDataObjectのインスタンスを生成する myLib.GetFromClipboard On Error Resume Next V = myLib.GetText On Error GoTo 0 If Not IsEmpty(V) Then V = Split(CStr(V), vbCrLf) ActiveCell.AutoFilter Field:=1 '引数は既にオートフィルターがある場合に解除しないためのダミー XP = ActiveCell.Column '現在選択しているセルの列番号を取得 XS = ActiveCell.Worksheet.AutoFilter.Range.Column 'オートフィルターが適用される範囲の左端の列番号を取得 XP = XP + 1 - XS '抽出条件の対象となる列番号 YS = ActiveCell.Worksheet.AutoFilter.Range.Row 'オートフィルターが適用される範囲の上端の行番号を取得 YE = ActiveCell.Worksheet.AutoFilter.Range.Rows(ActiveCell.Worksheet.AutoFilter.Range.Rows.Count).Row 'オートフィルターが適用される範囲の下端の行番号を取得 i = 0 Do While i <= UBound(V) ActiveCell.AutoFilter Field:=XP, Criteria1:=V(i), Operator:=xlFilterValues 可視セル数 = Range(Cells(YS, XP), Cells(YE, XP)).Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count If 可視セル数 > 1 Then ActiveSheet.PrintOut: DoEvents '絞り込みに一致するものがあった場合のみ印刷する i = i + 1 Loop Else MsgBox "クリップボードにデータがありません！" End If End Sub
※コードの使用方法
SubからEnd Subまでをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら。
実行手順
- まず、抽出条件にしたい文字列が入ったセルを複数選択した状態で、コード１を実行します。（この処理で各文字列がクリップボードに一時保存されます。既に各文字列が改行で区切られた状態でクリップボードに入っていれば、この手順は省略できます。例えば、ブラウザやエディタ等々からのコピーでも可）
- 絞り込みしたい列のどこでもいいので選択し、コード２を実行します。
実行風景（手順１は省略）
※実際はもっと高速です。目で見えるようにステップ実行しています。
プログラムの説明
◇コード１
- 選択されたセルから文字列を取得し、末尾に改行を付け足して変数に代入する
- 選択されたすべてのセルに対して、上記を繰り返す
- 最後に処理したセルの改行が邪魔なので取り除く
- 変数の内容をクリップボードに転送する
◇コード２
- クリップボードのデータを取り込み、Split関数で改行までを一つのデータとして配列に格納する
- シートにオートフィルターがない場合は、現在選択中のセルを含むアクティブセル領域をオートフィルターに設定
- オートフィルターが適用される範囲の左端を取得
- 現在選択中のセルがオートフィルター範囲の左端から何列目かを取得
- オートフィルターが適用される範囲の上端、下端をそれぞれ取得（絞り込み結果が「無し」だった場合の判定用に）
- Do While ～Loopで、以下の処理を配列の全要素について実施する
- オートフィルターで絞り込みを行う（抽出条件は配列の値）
- オートフィルターが適用される範囲の上端から下端までの縦方向の可視セル数をカウントする
- 可視セル数が1を超えていれば、絞り込み結果「有り」として、現在の印刷設定で印刷を行う。1以下であれば絞り込み結果が「無し」のため印刷しない（下のように見出しのみ可視セルとなる）。
印刷を数百回繰り返すような場合はマクロ実行後、終わるまでコーヒーでも飲んでいるか、別の仕事でもしているのが吉です。ただし、プリンタ側の用紙切れ・トナー切れ・用紙詰まりなどの異常をVBA側で検知する術がないので（APIでもできないはず･･････）要注意。VBAはプリンタが死んでいてもガトリングガンのように印刷指令を撃ち続けます。
指定文字列の左側または右側を切り出す
今回は指定文字列の左側または右側を切り出すコードを考えてみたいと思います。例えば、氏名から、スペースを境にして姓と名を切り出したい･･････。とか。
ただ、そんなのは既に世の中にある気がするので、そこから半歩進んだ処理も考えてみたいと思います。
境にしたい指定文字列がセル内に複数ある場合、左から何個目かを指定できるようにする。
こんな感じ。
左から２個目の全角スラッシュを境にして、左側または右側を切り出したい。
左側を切り出した結果
右側を切り出した結果
ということで、コードを作ってみました。（ついでに、指定文字列を含んで切り出すかどうかも選択できるようにした）
左側を切り出すコード
Sub 指定文字の左側を切り出す() '選択範囲に対して処理を行います Dim 指定文字 As String Dim 境 As Integer Dim tmp As Integer Dim 含 As Integer Dim myRange As Range Dim 始 As Integer Dim i As Integer Dim 位置 As Integer 指定文字 = InputBox("指定文字を入力して下さい。") If 指定文字 = "" Then Exit Sub 境 = InputBox("左から何個目の指定文字を境にしますか？") tmp = MsgBox("指定文字を含んで切り出しますか？", vbYesNoCancel) If tmp = vbYes Then 含 = Len(指定文字) ElseIf tmp = vbNo Then 含 = 0 Else Exit Sub End If For Each myRange In Selection 始 = 1 '検索開始位置 For i = 2 To 境 '左から2個目以降の指定文字を境にした場合の検索開始位置を求める If InStr(始, myRange.Value, 指定文字) > 0 Then 始 = InStr(始, myRange.Value, 指定文字) + Len(指定文字) Else Exit For End If Next i 位置 = InStr(始, myRange.Value, 指定文字) If 位置 > 0 Then myRange.Value = Left(myRange.Value, 位置 + 含 - 1) End If Next myRange End Sub
右側を切り出すコード
Sub 指定文字の右側を切り出す() '選択範囲に対して処理を行います Dim 指定文字 As String Dim 境 As Integer Dim tmp As Integer Dim 含 As Integer Dim myRange As Range Dim 始 As Integer Dim i As Integer Dim 位置 As Integer 指定文字 = InputBox("指定文字を入力して下さい。") If 指定文字 = "" Then Exit Sub 境 = InputBox("左から何個目の指定文字を境にしますか？") tmp = MsgBox("指定文字を含んで切り出しますか？", vbYesNoCancel) If tmp = vbYes Then 含 = 0 ElseIf tmp = vbNo Then 含 = Len(指定文字) Else Exit Sub End If For Each myRange In Selection 始 = 1 '検索開始位置 For i = 2 To 境 '左から2個目以降の指定文字を境にした場合の検索開始位置を求める If InStr(始, myRange.Value, 指定文字) > 0 Then 始 = InStr(始, myRange.Value, 指定文字) + Len(指定文字) Else Exit For End If Next i 位置 = InStr(始, myRange.Value, 指定文字) If 位置 > 0 Then myRange.Value = Right(myRange.Value, Len(myRange.Value) - 位置 - 含 + 1) End If Next myRange End Sub
※コードの使用方法
SubからEnd Subまでをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら。
実行手順
- 処理したい範囲を選択してマクロを実行する。
- InputBoxが表示されるので、指定文字列を入力する。（必ずしも、1文字である必要は無い）
- 引き続きInputBoxが表示されるので、左から何個目の指定文字列を境にするかを入力する。
- 指定文字列を含んで切り出すかどうかを、「はい」「いいえ」で選択する。
プログラムの説明
- InputBoxおよびMsgBoxで処理に必要な情報の入力を促す。
- For Each ～Nextで選択範囲に対して順番に処理を行う。
- 文字列検索開始位置の初期値を1文字目とする。
- For ～Nextの処理。境とする文字列を左から2個目以降とした場合の、文字列検索開始位置を求める。（左から1文字目とした場合、このループには入らない）
- InStr関数で、指定文字列（n個目）の位置を求める。
- 左側から（または右側から）指定文字列の手前までを切り出す。※指定文字列を含むを「はい」にした場合は、含んで切り出す。
余談ですが、Excel 2013以降であればフラッシュフィルで似たようなこともできます。（ただ、フラッシュフィルでは思った通りの結果にならないこともあったりする）
追記
ことりちゅんさんのコメントにあるように、Split関数の第三引数 Limitを活用したコードを作ってみました。元のコードは極力そのままでSplit関数に置き換えています。右側を切り出すコードに関してはかなりスッキリしました。
右側を切り出すコード（元コードとの違いを赤にしています）
Sub 指定文字の右側を切り出すlimit版()
'選択範囲に対して処理を行います
Dim 指定文字 As String
Dim 境 As Integer
Dim tmp As Integer
Dim 含 As String
Dim myRange As Range
Dim 配列 As Variant
指定文字 = InputBox("指定文字を入力して下さい。")
If 指定文字 = "" Then Exit Sub
境 = InputBox("左から何個目の指定文字を境にしますか？")
tmp = MsgBox("指定文字を含んで切り出しますか？", vbYesNoCancel)
If tmp = vbYes Then
含 = 指定文字
ElseIf tmp = vbNo Then
含 = ""
Else
Exit Sub
End If
For Each myRange In Selection
配列 = Split(myRange.Value, 指定文字, 境 + 1)
myRange.Value = 含 & 配列(UBound(配列))
Next myRange
End Sub
左側を切り出すコード（上記、右側を切り出すコードとの違いを紫にしています）
Sub 指定文字の左側を切り出すlimit版()
'選択範囲に対して処理を行います
Dim 指定文字 As String
Dim 境 As Integer
Dim tmp As Integer
Dim 含 As String
Dim myRange As Range
Dim 総数 As Integer
Dim 配列 As Variant
指定文字 = InputBox("指定文字を入力して下さい。")
If 指定文字 = "" Then Exit Sub
境 = InputBox("左から何個目の指定文字を境にしますか？")
tmp = MsgBox("指定文字を含んで切り出しますか？", vbYesNoCancel)
If tmp = vbYes Then
含 = 指定文字
ElseIf tmp = vbNo Then
含 = ""
Else
Exit Sub
End If
For Each myRange In Selection
総数 = (Len(myRange.Value) - Len(Replace(myRange.Value, 指定文字, ""))) / Len(指定文字) 'セル内の指定文字の総数を求める
配列 = Split(StrReverse(myRange.Value), StrReverse(指定文字), 総数 - 境 + 2)
myRange.Value = StrReverse(配列(UBound(配列))) & 含
Next myRange
End Sub
ある行の高さや列幅を、他の行または列に適用する
エクセルを使用していると、行の高さや列の幅をコピーして他の行・列に適用したいときがあります。
そんなときはどうすればいいでしょうか？
目次
形式を選択して貼り付けする方法
数式や書式のみをコピーして貼り付けできるのと同じように、列幅のみをコピーして貼り付けることができます。
･･････あれ？行高さは？
なぜか、形式を選択して貼り付けする方法には行高さのみをコピペする機能がありません。
高さや幅を確認してから、他の行・列に設定する方法
これが一番原始的な方法です。お手本にしたい行や列の境目あたり（カーソルの形が変わる所）でクリックして、値を確認し
次に、値を同じにしたい行または列を選択した状態で右クリック→「行の高さ（または列の幅）」で同じ値を入力してOKします。
ただし、値を確認し、入力する手間があります。
マクロで適用する方法
上の方法でも十分なのですが、ちょっとだけ（ほんのちょっとだけ）簡単にできるマクロを作ってみました。
Sub 行の高さや列幅を他の行または列に適用する() '適用先の行全体または列全体を選択した状態で実行する 'インプットボックスで適用元の行または列を指定する Dim 列番号 As String Dim 列幅 As Double Dim 行番号 As Long Dim 行高さ As Double If Selection.Address = Selection.EntireColumn.Address Then 列番号 = InputBox("列幅の適用元となる列番号をアルファベットで指定") 列番号 = StrConv(列番号, vbNarrow) If 列番号 Like "*[!A-Za-z]*" Then GoTo エラー処理 On Error GoTo エラー処理 列幅 = Columns(列番号).ColumnWidth On Error GoTo 0 Selection.ColumnWidth = 列幅 ElseIf Selection.Address = Selection.EntireRow.Address Then 行番号 = InputBox("行高さの適用元となる行番号を指定") On Error GoTo エラー処理 行高さ = Rows(行番号).RowHeight On Error GoTo 0 Selection.RowHeight = 行高さ End If Exit Sub エラー処理: MsgBox "存在しない行または列です。" End Sub
※コードの使用方法
SubからEnd Subまでをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら。
実行手順
- 高さや幅を変更したい行または列を選択した状態でマクロを実行。
- InputBoxが表示されるので、お手本にしたい行または列を入力してOKする。※行は数字、列はアルファベットで入力する。
･･････ここまで書いてアレですが、マクロを用意するほどでもなかったかも。
複数のセルの色でフィルタリングを行う
前回は複数の文字の色でしたが、今回は複数のセルの色でフィルタリングしてみましょう。内容は一部、前回と重複しますのでご了承ください。
エクセルのオートフィルターはセルの色でフィルターをかけることができますが、色は一つしか指定できません。また、複数のセルを選んで右クリックし、「フィルター」→「選択したセルの色でフィルター」をしようとしても、複数の選択範囲に対しては実効できない旨の警告メッセージが出てしまいます。
VBAならと思ったのですが、用意されているメソッドや関数ではできないみたいです。（たぶん）
ということで、複数のセルの色でフィルタリングできるコードを作ってみました。
（今回は二つのコードを使います）
コード１
Sub セル色の値を改行区切りでクリップボードに格納() '格納する値はリトルエンディアンです Dim myRange As Range Dim V As String Dim myLib As Object Set myLib = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '参照設定なしでDataObjectのインスタンスを生成する If Selection.Count > 1 Then For Each myRange In Selection.SpecialCells(xlCellTypeVisible) '可視セルのみに処理を行う If myRange.Address = myRange.MergeArea(1).Address Then '結合セルの場合は左上の値のみ取り出す V = V & myRange.Interior.Color & vbCrLf End If Next myRange V = Left(V, Len(V) - 2) '最終行の改行区切りを取り除く（CrLfは2文字） Else V = ActiveCell.Interior.Color End If myLib.SetText V '変数の値をDataObjectに格納する myLib.PutInClipboard 'DataObjectのデータをクリップボードに格納する End Sub
コード２
Sub 複数のセルの色で絞込みを行う() 'クリップボードに格納されたセル色の値を参照し、OR条件で絞込みします '実行前に絞り込みを行う列範囲（見出しを除く）を選択しておきます 'セル色が一致しない行を非表示にします（オートフィルターを使いません） Dim V As Variant Dim i As Integer Dim x As Integer Dim y As Long Dim Yn As Long Dim myRange As Range Dim myLib As Object Set myLib = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '参照設定なしでDataObjectのインスタンスを生成する Application.ScreenUpdating = False '画面表示の更新をオフにする myLib.GetFromClipboard On Error Resume Next V = myLib.GetText On Error GoTo 0 If Not IsEmpty(V) Then V = Split(CStr(V), vbCrLf) x = Selection.Column For y = Selection.Row To Selection.Rows(Selection.Rows.Count).Row i = 0 Do While i <= UBound(V) If CStr(Cells(y, x).Interior.Color) = V(i) Then '配列の内容と一致している場合は行を進める Yn = y + 1 Do While Cells(y, x).Address = Cells(Yn, x).MergeArea(1).Address '結合セルを抜けるまで行を進める Yn = Yn + 1 Loop y = Yn - 1 GoTo nx Else i = i + 1 End If Loop If myRange Is Nothing Then Set myRange = Range(y & ":" & y) '配列の内容全てと一致しなかった一番最初の行 Else Set myRange = Union(myRange, Range(y & ":" & y)) '配列の内容全てと一致しなかった行 End If nx: Next y myRange.EntireRow.Hidden = True '検索に一致しなかった行をすべて非表示にする Else MsgBox "クリップボードにデータがありません！" End If End Sub
※コードの使用方法 SubからEnd Subまでをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら。
実行手順
- まず、フィルターに使用したい色のセルを複数選択した状態で、コード１を実行します。（この処理でセル色の値がクリップボードに一時保存されます）
- フィルタリングしたい列の範囲を選択し、コード２を実行します。
実行風景（事前に実行手順の1.で赤・青・黄のセル色を取得済み）
フィルタリング解除は、標準機能で行を再表示しています。
プログラムの説明
- 割愛
課題
複数の文字の色でフィルタリングを行う
エクセルのオートフィルターは文字の色でフィルターをかけることができますが、色は一つしか指定できません。また、複数のセルを選んで右クリックし、「フィルター」→「選択したセルのフォント色でフィルター」をしようとしても、複数の選択範囲に対しては実効できない旨の警告メッセージが出てしまいます。
VBAならと思ったのですが、用意されているメソッドや関数ではできないみたいです。（たぶん）
ということで、複数の文字の色でフィルタリングできるコードを作ってみました。
（今回は二つのコードを使います）
コード１
Sub 文字色の値を改行区切りでクリップボードに格納() '格納する値はリトルエンディアンです '複数の文字色が混在するセルはNullとなります Dim myRange As Range Dim V As String Dim myLib As Object Set myLib = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '参照設定なしでDataObjectのインスタンスを生成する If Selection.Count > 1 Then For Each myRange In Selection.SpecialCells(xlCellTypeVisible) '可視セルのみに処理を行う If myRange.Address = myRange.MergeArea(1).Address Then '結合セルの場合は左上の値のみ取り出す V = V & myRange.Font.Color & vbCrLf End If Next myRange V = Left(V, Len(V) - 2) '最終行の改行区切りを取り除く（CrLfは2文字） Else V = ActiveCell.Font.Color End If myLib.SetText V '変数の値をDataObjectに格納する myLib.PutInClipboard 'DataObjectのデータをクリップボードに格納する End Sub
コード２
Sub 複数の文字の色で絞込みを行う() 'クリップボードに格納された文字色の値を参照し、OR条件で絞込みします '実行前に絞り込みを行う列範囲（見出しを除く）を選択しておきます '文字色が一致しない行を非表示にします（オートフィルターを使いません） Dim V As Variant Dim i As Integer Dim x As Integer Dim y As Long Dim Yn As Long Dim myRange As Range Dim myLib As Object Set myLib = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") '参照設定なしでDataObjectのインスタンスを生成する Application.ScreenUpdating = False '画面表示の更新をオフにする myLib.GetFromClipboard On Error Resume Next V = myLib.GetText On Error GoTo 0 If Not IsEmpty(V) Then V = Split(CStr(V), vbCrLf) x = Selection.Column For y = Selection.Row To Selection.Rows(Selection.Rows.Count).Row i = 0 If Not IsNull(Cells(y, x).Font.Color) And Not Cells(y, x).Value = "" Then '複数の文字色が混在するセル（Null）と空白のセル（黒と値が重複）は、検索の対象外 Do While i <= UBound(V) If CStr(Cells(y, x).Font.Color) = V(i) Then '配列の内容と一致している場合は行を進める Yn = y + 1 Do While Cells(y, x).Address = Cells(Yn, x).MergeArea(1).Address '結合セルを抜けるまで行を進める Yn = Yn + 1 Loop y = Yn - 1 GoTo nx Else i = i + 1 End If Loop End If If myRange Is Nothing Then Set myRange = Range(y & ":" & y) '配列の内容全てと一致しなかった一番最初の行 Else Set myRange = Union(myRange, Range(y & ":" & y)) '配列の内容全てと一致しなかった行 End If nx: Next y myRange.EntireRow.Hidden = True '検索に一致しなかった行をすべて非表示にする Else MsgBox "クリップボードにデータがありません！" End If End Sub
※コードの使用方法
SubからEnd Subまでをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら。
実行手順
- まず、フィルターに使用したい文字色のセルを複数選択した状態で、コード１を実行します。（この処理で文字色の値がクリップボードに一時保存されます）
- フィルタリングしたい列の範囲を選択し、コード２を実行します。
実行風景（事前に実行手順の1.で赤・青・黄の文字色を取得済み）
フィルタリング解除は、標準機能で行を再表示しています。
プログラムの説明
◇コード１
- 選択されたセルからFont.Colorで文字色の値を取得し、末尾に改行を付け足して変数に代入する
- 選択されたすべてのセルに対して、上記を繰り返す
- 最後に処理したセルの改行が邪魔なので取り除く
- 変数の内容をクリップボードに転送する
◇コード２
- クリップボードのデータを取り込み、Split関数で改行までを一つのデータとして配列に格納する
- 現在選択している範囲の列番号を取得する
- For Nextの始まりの値を選択範囲の上端の行、終わりの値を下端の行をする
- まずは上端の行から、配列内のデータと一致するか否か比較を行う
- 配列内のいずれかのデータと一致していれば、Next yへ飛ぶ（一致したセルが結合セルの場合は、結合セルを抜けるまで行を進める）
- 配列内のデータすべてと一致しなかった場合は、その行をUnionメソッドで記憶しておく
- 下端の行まで、For ～Nextの繰り返し
- 最後に、検索に一致しなかった行をまとめて非表示にする
- また、下のように複数の文字色が混在するセルは、Font.Colorの値がNullとなるため検索の対象外とし、すべて非表示にする。
空白のセルはFont.Colorの値が黒の文字色と同じになるので、これも検索の対象外とし、すべて非表示にする。
課題
同じデータのセルを結合する
今回は隣接するセルのデータが同じであれば、セル結合する。というコードを作ってみたいと思います。
しかし、
「セル結合はなるべく避けるべし」
「すぐにセル結合したがる民は滅んでほしい」
「最初からこの機能が無ければよかった」
と、いうような声もよく耳にします。
確かに、多くの人でデータを共有したりするようなエクセルシートであれば、エクセルの便利な機能が殺されてしまい、思わぬ迷惑をかけてしまうことがあります。
しかし、使い捨てで、他人に渡すようなものでなければ、見やすくするためにちょっとくらい結合したっていいじゃん。という思いもあったりします。
実際、私はよくやります。（←ぇ）
だからといって、手動で1個ずつ結合していくのも面倒くさいです。なので「縦方向（または横方向）に隣接するセルのデータが同じならセル結合する」というコードを作ってみました。禁忌を積極的に破るようで気が引けますけどね･･････。
Sub 同じデータのセルを結合する() Dim 列 As Long Dim 行 As Long Dim 行終 As Long Dim 列終 As Long Dim myUni As Range Application.DisplayAlerts = False If Selection.Rows.Count > 1 And Selection.Columns.Count = 1 Then '下方向に選択したときの処理 列 = Selection.Column 行 = Selection.Row + 1 行終 = Selection.Rows(Selection.Rows.Count).Row Do While 行 <= 行終 If Cells(行 - 1, 列).MergeArea(1).Value = Cells(行, 列).MergeArea(1).Value Then If myUni Is Nothing Then Set myUni = Range(Cells(行 - 1, 列), Cells(行, 列)) Else Set myUni = Union(myUni, Cells(行, 列)) End If Else If Not myUni Is Nothing Then myUni.Merge Set myUni = Nothing End If End If 行 = 行 + 1 Loop ElseIf Selection.Rows.Count = 1 And Selection.Columns.Count > 1 Then '右方向に選択したときの処理 行 = Selection.Row 列 = Selection.Column + 1 列終 = Selection.Columns(Selection.Columns.Count).Column Do While 列 <= 列終 If Cells(行, 列 - 1).MergeArea(1).Value = Cells(行, 列).MergeArea(1).Value Then If myUni Is Nothing Then Set myUni = Range(Cells(行, 列 - 1), Cells(行, 列)) Else Set myUni = Union(myUni, Cells(行, 列)) End If Else If Not myUni Is Nothing Then myUni.Merge Set myUni = Nothing End If End If 列 = 列 + 1 Loop End If If Not myUni Is Nothing Then '行終または列終を含むセルの結合 myUni.Merge End If End Sub
※コードの使用方法
SubからEnd Subまでをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら。
プログラムの説明
- 割愛
実行風景
縦方向・横方向のどちら側に選択しているかはプログラムが自動判別してくれます。
集計の機能を犠牲にして、刹那的に見やすくするだけの他愛のないコードですね（￣ｑ￣;）
冒頭でも触れましたが、公の場でセル結合を乱用すると謎の勢力に命を狙われますので、その点は注意して下さい。
