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)メソッドを使わない処理

に分岐させているだけです。

オートフィルタで絞り込んで印刷（を抽出条件の分だけ繰り返す）

今回はオートフィルタで絞り込んでから印刷する、という作業を自動化してみたいと思います。
こんなイメージ。

この表の商品の列で、

1. "ポーション"で絞り込み
2. 印刷
3. "金の針"で絞り込み
4. 印刷
5. "フェニックスの尾"で絞り込み
6. 印刷
7. "エリクサー"で絞り込み
8. 印刷
9. 終了

 

というような繰り返しを自動化します。

さっそくコードを作ってみました。

 

コード１

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までをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら。

 

実行手順

1. まず、抽出条件にしたい文字列が入ったセルを複数選択した状態で、コード１を実行します。（この処理で各文字列がクリップボードに一時保存されます。既に各文字列が改行で区切られた状態でクリップボードに入っていれば、この手順は省略できます。例えば、ブラウザやエディタ等々からのコピーでも可）
2. 絞り込みしたい列のどこでもいいので選択し、コード２を実行します。

 

実行風景（手順１は省略）

• ※実際はもっと高速です。目で見えるようにステップ実行しています。

 

プログラムの説明
◇コード１

• 選択されたセルから文字列を取得し、末尾に改行を付け足して変数に代入する
• 選択されたすべてのセルに対して、上記を繰り返す
• 最後に処理したセルの改行が邪魔なので取り除く
• 変数の内容をクリップボードに転送する

◇コード２

• クリップボードのデータを取り込み、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までをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら。

 

実行手順

1. 処理したい範囲を選択してマクロを実行する。
2. InputBoxが表示されるので、指定文字列を入力する。（必ずしも、1文字である必要は無い）
3. 引き続きInputBoxが表示されるので、左から何個目の指定文字列を境にするかを入力する。
4. 指定文字列を含んで切り出すかどうかを、「はい」「いいえ」で選択する。

 

プログラムの説明

• 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までをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら。

 

実行手順

1. 高さや幅を変更したい行または列を選択した状態でマクロを実行。
2. InputBoxが表示されるので、お手本にしたい行または列を入力してOKする。※行は数字、列はアルファベットで入力する。

 

･･････ここまで書いてアレですが、マクロを用意するほどでもなかったかも。

複数のセルの色でフィルタリングを行う

前回は複数の文字の色でしたが、今回は複数のセルの色でフィルタリングしてみましょう。内容は一部、前回と重複しますのでご了承ください。

kouten0430.hatenablog.com

エクセルのオートフィルターはセルの色でフィルターをかけることができますが、色は一つしか指定できません。また、複数のセルを選んで右クリックし、「フィルター」→「選択したセルの色でフィルター」をしようとしても、複数の選択範囲に対しては実効できない旨の警告メッセージが出てしまいます。

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. まず、フィルターに使用したい色のセルを複数選択した状態で、コード１を実行します。（この処理でセル色の値がクリップボードに一時保存されます）
2. フィルタリングしたい列の範囲を選択し、コード２を実行します。

 

実行風景（事前に実行手順の1.で赤・青・黄のセル色を取得済み）

フィルタリング解除は、標準機能で行を再表示しています。

 

プログラムの説明

• 割愛

 

課題

• 二つのコードを使うので煩雑。
• クリップボードを使う方法は安定しない場合がある。（私の環境だと、クリップボードへのアクセスに数百回に一度失敗するかどうかなので実用上問題なし）
• フィルタリング範囲を手動で選択するのが面倒。※自動で選択させる方法（CurrentRegionを使う方法・シートの最終行からEnd(xlUp)する方法・罫線の有無で判定する方法）もあるけど、表の作り方は人によって千差万別なので確実に自動選択できる保証がない･･････。
• フィルタリングの解除が面倒。

複数の文字の色でフィルタリングを行う

エクセルのオートフィルターは文字の色でフィルターをかけることができますが、色は一つしか指定できません。また、複数のセルを選んで右クリックし、「フィルター」→「選択したセルのフォント色でフィルター」をしようとしても、複数の選択範囲に対しては実効できない旨の警告メッセージが出てしまいます。
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. まず、フィルターに使用したい文字色のセルを複数選択した状態で、コード１を実行します。（この処理で文字色の値がクリップボードに一時保存されます）
2. フィルタリングしたい列の範囲を選択し、コード２を実行します。

 

実行風景（事前に実行手順の1.で赤・青・黄の文字色を取得済み）

フィルタリング解除は、標準機能で行を再表示しています。

 

プログラムの説明
◇コード１

• 選択されたセルからFont.Colorで文字色の値を取得し、末尾に改行を付け足して変数に代入する
• 選択されたすべてのセルに対して、上記を繰り返す
• 最後に処理したセルの改行が邪魔なので取り除く
• 変数の内容をクリップボードに転送する

 

◇コード２

• クリップボードのデータを取り込み、Split関数で改行までを一つのデータとして配列に格納する
• 現在選択している範囲の列番号を取得する
• For Nextの始まりの値を選択範囲の上端の行、終わりの値を下端の行をする
• まずは上端の行から、配列内のデータと一致するか否か比較を行う
• 配列内のいずれかのデータと一致していれば、Next yへ飛ぶ（一致したセルが結合セルの場合は、結合セルを抜けるまで行を進める）
• 配列内のデータすべてと一致しなかった場合は、その行をUnionメソッドで記憶しておく
• 下端の行まで、For ～Nextの繰り返し
• 最後に、検索に一致しなかった行をまとめて非表示にする
• また、下のように複数の文字色が混在するセルは、Font.Colorの値がNullとなるため検索の対象外とし、すべて非表示にする。

  

  空白のセルはFont.Colorの値が黒の文字色と同じになるので、これも検索の対象外とし、すべて非表示にする。

 

課題

• 二つのコードを使うので煩雑。
• クリップボードを使う方法は安定しない場合がある。（私の環境だと、クリップボードへのアクセスに数百回に一度失敗するかどうかなので実用上問題なし）
• フィルタリング範囲を手動で選択するのが面倒。※自動で選択させる方法（CurrentRegionを使う方法・シートの最終行からEnd(xlUp)する方法・罫線の有無で判定する方法）もあるけど、表の作り方は人によって千差万別なので確実に自動選択できる保証がない･･････。
• フィルタリングの解除が面倒。

同じデータのセルを結合する

今回は隣接するセルのデータが同じであれば、セル結合する。というコードを作ってみたいと思います。

しかし、

「セル結合はなるべく避けるべし」

「すぐにセル結合したがる民は滅んでほしい」

「最初からこの機能が無ければよかった」

と、いうような声もよく耳にします。
確かに、多くの人でデータを共有したりするようなエクセルシートであれば、エクセルの便利な機能が殺されてしまい、思わぬ迷惑をかけてしまうことがあります。
しかし、使い捨てで、他人に渡すようなものでなければ、見やすくするためにちょっとくらい結合したっていいじゃん。という思いもあったりします。

 

実際、私はよくやります。（←ぇ）

 

だからといって、手動で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までをコピーし、標準モジュール等に貼り付けて使用して下さい。なお、マクロで実行した処理は「元に戻す」ことができません。実行前に一旦保存しやり直しのできる状態にしておいて下さい。標準モジュールにコードを貼り付けてマクロを使用する方法はこちら。

 

プログラムの説明

• 割愛

 

実行風景

縦方向・横方向のどちら側に選択しているかはプログラムが自動判別してくれます。

集計の機能を犠牲にして、刹那的に見やすくするだけの他愛のないコードですね（￣ｑ￣;）

 

 冒頭でも触れましたが、公の場でセル結合を乱用すると謎の勢力に命を狙われますので、その点は注意して下さい。