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

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

f:id:kouten0430:20190830160050p:plain

この表の商品の列で、

"ポーション"で絞り込み
印刷
"金の針"で絞り込み
印刷
"フェニックスの尾"で絞り込み
印刷
"エリクサー"で絞り込み
印刷
終了

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

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

コード１

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はプリンタが死んでいてもガトリングガンのように印刷指令を撃ち続けます。

VBAの勉強を始めてみた

色々試しています。

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