VBAの勉強を始めてみた

タイトルの通りVBAの勉強を始めました。効率化と暇つぶしを兼ねています。ブログの書き方なんて知りません分かりません。

クリップボードのデータを可視セルのみに貼り付ける

以前書いた内容と重複しますが、だるまさんという方が作られた

素晴らしいマクロがありますので紹介をさせていただきます。

だるまのつぶやき---エクセルVBA小技集

可視セルのみに貼り付けを行うというものです。

このマクロに自分好みの機能(選択中のセル位置から貼り付け)を付加したものを含め、紹介していきたいと思います。(二次創作という位置付けでご覧下さい・・・)

 

まず、下記のようなオートフィルター領域があります。

f:id:kouten0430:20170521164100j:plain

 

これをフィルタリングで「1」のみ抽出した状態にします。

f:id:kouten0430:20170521164347j:plain

 

ここで、B4セルに下記のようなクリップボードのデータを貼り付けると・・・

f:id:kouten0430:20170521164526j:plain

f:id:kouten0430:20170521164555j:plain

 

何だかおかしいですよね?

フィルターを解除してみると

f:id:kouten0430:20170521164711j:plain

非表示だったセルに、連続してデータが貼り付けられてしまっています。

 

ここで、今回紹介するマクロを使用すると、

f:id:kouten0430:20170521164840j:plain

可視セルのみに貼り付けすることができます。

f:id:kouten0430:20170521164932j:plain

 

ちなみに、セルを変えてマクロを実行すると、その位置から貼り付けが実行されます。

f:id:kouten0430:20170521165334j:plain

f:id:kouten0430:20170521165356j:plain

 

横方向にもデータがある場合はどうなるでしょうか?

f:id:kouten0430:20170521165838j:plain

 

EXCELでコピーしたデータは下記のように、Tab区切りと改行区切りのデータとしてクリップボードに格納されます。

f:id:kouten0430:20170521165904j:plain

 

このクリップボードのデータをマクロで貼り付けると以下のようになります。

f:id:kouten0430:20170521170130j:plain

f:id:kouten0430:20170521170157j:plain

 

注意点としては、EXCELでコピーしたデータはマクロを実行する前に一旦クリップボードが空になってしまうので、メモ帳などを経由するようにするといいと思います。

 

以下はVBAのコードです。(青色は私が趣味で付加したものです)

 

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

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

    If ActiveSheet.AutoFilter Is Nothing Then
        MsgBox "オートフィルターが設定されていません!"
        Exit Sub
    End If

    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
    'オートフィルターが適用される範囲の下端の行番号を取得

    If YP < YS Or YP > YE Then
        MsgBox "オートフィルター範囲外(上・下方向)には貼り付けできません!"
        Exit Sub
    End If
   
    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
            If V(i) = "" Then   '空白行がある場合のエラーを回避
                A = CStr(V(i))
                R.Value = A
            Else
                A = Split(CStr(V(i)), vbTab)
                R.Resize(, UBound(A) + 1).Value = A
            End If
           
            i = i + 1
            If i > UBound(V) Then Exit For
        Next
    Else
        MsgBox "クリップボードにデータがありません!"
        Exit Sub
    End If
   
    Set Dobj = Nothing
    Set rngDest = Nothing
    Set R = Nothing
End Sub

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

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

 

上記のコードを実行してコンパイルエラーが発生する場合は?

このコードにはDataObjectという、VBAの標準にはないオブジェクトが使用されているため、実行するにはMicrosoft Forms 2.0 Object Libraryという外部ライブラリーを参照する設定を行う必要があります。つまり具体的に言うとVBEのツール→参照設定→参照からWindows\System32\FM20.DLLを選択する必要があるわけです。(FM20.DLLの保存場所はOSのバージョンによって異なる場合がありますが・・・)