コピー元範囲に値が入ってるセルのみ貼り付けるアドイン

タイトル見ても何のこっちゃ？だと思われるので、絵貼って説明します。

↓な状態でB3〜C8のセルをコピーし、E3〜F8の範囲に貼り付けると

↓となります。(；^ω^)当り前お…

でも、このアドインでコピペすると、↓なります。

使い道はあんまりないかもしれませんが、せっかく作ったんでupしてみました。
※自分の業務で、こういう風に出来ると便利な時があるんです。(；^ω^)

ソース

'ThisWorkbookモジュール
Option Explicit
Private Const cnsMenuName As String = "Skip Paste"

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    On Error Resume Next
    Application.CommandBars("Cell").Controls(cnsMenuName).Delete
    On Error GoTo 0
    
End Sub

Private Sub Workbook_Open()

    'アイコンのFaceID
    Const cnsFaceID   As Long = 3053
    'ツールチップテキスト
    Const cnsTipText  As String = "値が入力済みのセルをスキップして貼り付けます"
    'プロシージャー名
    Const cnsProcName As String = "SkipPaste"

    Dim cbCell        As CommandBar
    Dim cbNewMenu     As CommandBarButton
    
    Set cbCell = Application.CommandBars("Cell")

    '新規作成するメニューを予め削除しておく
    On Error Resume Next
    cbCell.Controls(cnsMenuName).Delete
    On Error GoTo 0
    
    Set cbNewMenu = cbCell.Controls.Add(Type:=msoControlButton)
    
    With cbNewMenu
        .TooltipText = cnsTipText
        .FaceId = cnsFaceID
        .Caption = cnsMenuName
        .OnAction = cnsProcName
    End With
    
    Set cbNewMenu = Nothing
    Set cbCell = Nothing

End Sub

'標準モジュール
Option Explicit

Sub SkipPaste()

    Dim rngCopy   As Range
    Dim rngPaste  As Range
    Dim v         As Variant
    Dim i         As Long
    Dim j         As Long
    Dim buf       As String
    
    'Type=8だと、キャンセル押下時にエラーになるのでエラーは一旦無視させる
    On Error Resume Next

    Set rngCopy = Application.InputBox("コピー元を選択して下さい", , , , , , , 8)
    If Err.Number <> 0 Then Exit Sub

    Set rngPaste = Application.InputBox("コピー先を選択して下さい", , , , , , , 8)
    If Err.Number <> 0 Then Exit Sub

    If rngPaste.Cells.Count > 1 Then
        MsgBox "コピー先範囲の左上セルだけを選択して下さい", vbExclamation
        GoTo Finally
    End If
    
    On Error GoTo ErrHandler
    
    'コピー元を配列に放り込む
    v = rngCopy
    
    '配列の要素の分だけループ
    For i = 1 To UBound(v, 1)
        For j = 1 To UBound(v, 2)
            buf = Application.WorksheetFunction.Trim(v(i, j))
            '値が入力されてる時のみ貼り付ける。Spaceのみが入力されてる場合は貼り付けない
            If LenB(buf) <> 0 Then
                rngPaste.Offset(i - 1, j - 1).Value = buf
            End If
        Next j
    Next i

Finally:

    Set rngCopy = Nothing
    Set rngPaste = Nothing
    Exit Sub

ErrHandler:

    With Err
        MsgBox .Number & vbCrLf & .Description, vbCritical, "Error Occured..."
    End With
    Resume Finally

End Sub