VBA100本ノック 9本目：フィルターコピー - Infomentのブログ～Excel VBA奮闘記～

こちらで公開されている、100本ノックに挑戦。
www.excel-ubara.com
素晴らしい教材を公開いただき、ありがとうございます。

上記リンク先から、問題文を転載。
f:id:Infoment:20220114210548p:plain

条件を改めておさらいしてみる。

合格者シートを新規作成すること。
合格者の氏名だけをＡ列に列挙すること。
点数は非公開とすること。
何度でも実行できること。

それでは早速、作ってみよう。

Sub VBA_100Knock_009()

    ' 成績表シート。
    Dim ResultSheet As Worksheet
    Set ResultSheet = ActiveSheet

    ' 合格者シートを探す。あれば削除。
    Dim Ws As Worksheet
    Dim SheetName As String
        SheetName = "合格者シート"
        
        For Each Ws In Worksheets
            If Ws.Name = SheetName Then
                Application.DisplayAlerts = False
                Ws.Delete
                Application.DisplayAlerts = True
            End If
        Next
    
    ' 合格者シートを作成。
    Dim Sh As Worksheet
    Set Sh = Sheets.Add
        Sh.Name = SheetName
    
    ' 合格者の列で空白以外のセルを含む行と、一列目（氏名列）の交差する範囲をコピー。
    With ResultSheet
        Intersect(.Columns(7).SpecialCells(xlCellTypeConstants).EntireRow, .Columns(1)).Copy
    End With

    ' 合格者シートに貼り付け。
        Sh.Range("A1").PasteSpecial
        Application.CutCopyMode = False
        
End Sub

お題に反して、今回は強引に氏名を取得して貼り付けてみた。

ちなみに、過去に作成したクラスモジュールを使用すると、こうなる。
infoment.hatenablog.com
infoment.hatenablog.com

Sub VBA_100Knock_009()
    ' 成績表。
    Dim SourceArray As Variant
        SourceArray = Range("A1").CurrentRegion
        
    ' 合格者シート削除。
    Dim ApC As VBAProject.AppControl
    Set ApC = New VBAProject.AppControl
        ApC.SheetDeleteWithoutAlerts "合格者シート"
    
    ' 合否判定欄が空白のレコードを除去。
    Dim Seq As VBAProject.Seaquence
    Set Seq = New VBAProject.Seaquence    
    Dim ResultArray As Variant
        ResultArray = Seq.TargetArray(SourceArray) _
                        .RowFilter(filt:=vbNullString, _
                                   column_index:=7)
    ' 一列目のみ抽出。
        ResultArray = WorksheetFunction.index(ResultArray, 0, 1)
    ' 貼り付け。
        Seq.TargetArray(ResultArray).PasteArray _
            sheet_name:="合格者シート", column_autofit:=True
End Sub