VBAの勉強を始めてみた

タイトルの通りVBAの勉強を始めました。若干の発達障害があり、読みづらく分かりづらい点が多々あるかもしれませんが、ご了承下さい。

エラー処理について

前回はIF文を使用して想定されるエラーを処理していましたが、今回はOn Error GoToステートメントでざっくりエラー処理をしてみます。青色が今回追記した部分です。あわせて、不要になったIF文などをいくつか削除しました。

 

***************************************

Sub 選択セルから下方向へ可視セルのみに貼り付ける()

    'Microsoft Forms 2.0 Object Library に参照設定要
    '複数セルを選択した状態で実行するとアクティブセル(白抜き)が貼り付け開始位置となる
    '結合セルを選択した状態で実行すると結合セルの左上セルが貼り付け開始位置となる
    '結合セルに貼り付けたい場合は結合セルを選択する。もしくは結合セルの左端と同列のセルを選択する
    'クリップボードの空白行も貼り付ける。Tabは無視される。

    Dim Dobj As DataObject
    Dim V As Variant    'クリップボードのデータ全体
    Dim A As Variant    'その内の一行
    Dim rngDest As Range
    Dim R As Range
    Dim i As Integer
    Dim XS As Integer
    Dim XP As Integer
    Dim YS As Integer
    Dim YP As Integer
    Dim YE As Integer
   
    On Error GoTo ErrorHandler

    YP = ActiveCell.Row '現在選択しているセルの行番号を取得
    XP = ActiveCell.Column  '現在選択しているセルの列番号を取得
    XP = XP + 1 'AutoFilter.Rangeの左端の列番号が相対的に1となるようにする

    YS = ActiveCell.Worksheet.AutoFilter.Range.Row 'オートフィルターが適用される範囲の上端の行番号を取得
    XS = ActiveCell.Worksheet.AutoFilter.Range.Column 'オートフィルターが適用される範囲の左端の列番号を取得

    YE = ActiveCell.Worksheet.AutoFilter.Range.Rows(ActiveCell.Worksheet.AutoFilter.Range.Rows.Count).Row
    'オートフィルターが適用される範囲の下端の行番号を取得
   
    XP = XP - XS
    YP = YP - YS
   
    With ActiveCell.Worksheet.AutoFilter.Range
        Set rngDest = .Columns(XP)
        Set rngDest = Intersect(rngDest, rngDest.Offset(YP))
        If YP + YS = YE Then    '現在選択しているセルがオートフィルターが適用される範囲の下端の場合は可視セルの取得処理をパスする
        Else
            Set rngDest = rngDest.SpecialCells(xlCellTypeVisible)   '最後に可視セルを取得するのがみそ
        End If
    End With
   
    Set Dobj = New DataObject
    With Dobj
        .GetFromClipboard
        On Error Resume Next
        V = .GetText
        On Error GoTo 0
    End With
   
    If Not IsEmpty(V) Then    'クリップボードからテキストが取得できた時のみ実行
        V = Split(CStr(V), vbCrLf)
        i = 0
        For Each R In rngDest.Cells
            A = CStr(V(i))
            R.Value = A
            i = i + 1
            If i > UBound(V) Then Exit For
        Next
    End If
   
    Set Dobj = Nothing
    Set rngDest = Nothing
    Set R = Nothing
   
    Exit Sub
   
ErrorHandler:
    MsgBox "オートフィルターが設定されていないか、貼り付けできない位置を選択している可能性があります。"

End Sub

***************************************

 ※SubからEnd Subまでをコピペしてマクロを使用できます。使用の際は自己責任でお願いいたします。

 

前回のマクロと同じものですが、行数が少なくなった分少しすっきりしたような気がします。