メモ書き

いろいろ実験中

sample

Option Explicit

Sub a()
    echo
    
    'フィルターを設置 & フィルター条件を追加（フィルター自体を除去してからのほうが確実）
    ActiveSheet.AutoFilterMode = False
    Call Rows(2).AutoFilter(4, "f")
    Call Rows(2).AutoFilter(10, "<>○")
    
    '可視行をカウント（フィルター結果の行数をカウント）
    Debug.Print Range("A2").CurrentRegion.Columns(1).SpecialCells(xlCellTypeVisible).address
    Debug.Print Range("A2").CurrentRegion.Columns(1).SpecialCells(xlCellTypeVisible).Count - 2

    Debug.Print ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).address
    Debug.Print ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
    
    '可視セルに○を入力
    Cells(3, 12).Resize(11).SpecialCells(xlCellTypeVisible).Value = "○" '現在範囲の可視行だけ入力
    Range("A2").CurrentRegion.Columns(10).SpecialCells(xlCellTypeVisible).Value = "○" '現在範囲の可視行だけ入力
    
    '値貼り付け（フィルター条件を除去してからではないとエラーになる）
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilter.ShowAllData
    Call Range("A:A").Copy
    Call Range("A:A").PasteSpecial(xlPasteValues)
    
    'ステータスバーに進捗表示
    Dim i As Long
    For i = 0 To 1
        Application.StatusBar = "進捗：" & i & "/" & 100
    Next i
    Application.StatusBar = ""
    
    '指定した行を縦方向に結合
    Call VMerge(16, 3, 1, 6, Array(3, 4, 8, 9))
    
    'コピーモードを解除して、セルを選択
    Application.CutCopyMode = False
    Cells(10, 10).Activate
    Cells(1, 1).Activate
End Sub


'指定した行を縦方向に結合
Public Function VMerge( _
        ByVal RowIndex As Long, ByVal RowHeight As Long, _
        ByVal ColumnIndexFrom As Long, ByVal ColumnIndexTo As Long, _
        Optional ByVal NotMergeColumns As Variant _
    )
    Dim str As String, ColumnIndex As Long
    'セルのアドレスを取得
    For ColumnIndex = ColumnIndexFrom To ColumnIndexTo
        If F_Contains(NotMergeColumns, ColumnIndex) Then GoTo nc
        str = str & "," & Cells(RowIndex, ColumnIndex).Resize(RowHeight).address
nc: Next ColumnIndex
    'セル結合
    Application.DisplayAlerts = False
    Range(Mid(str, 2)).Merge
    Application.DisplayAlerts = True
End Function


'メッセージボックス
Public Function F_MsgBox(ByVal msg As String) As Boolean
    If MsgBox(msg, vbInformation + vbYesNoCancel) = vbYes Then F_MsgBox = True
End Function


'配列に値が含まれているか
Public Function F_Contains(ByVal ary As Variant, ByVal Value As Variant) As Boolean
    Dim v As Variant
    For Each v In ary
        If v = Value Then F_Contains = True
    Next v
End Function