【Excel VBA】可視セルのみコピー、可視セルにのみ貼り付ける方法

皆さんは可視セルのみコピーして、可視セルにのみ貼り付けたいと思ったことはありませんか？

今回はそのような方に方法をご紹介します。

可視セルのみコピー

こちらは非常に簡単です。

Sub test()
    
    Selection.SpecialCells(xlCellTypeVisible).Copy
    
End Sub

Sub test()

Selection.SpecialCells(xlCellTypeVisible).Copy

End Sub

これで選択範囲の可視セルのみがコピーされます。

可視セルにのみ貼り付け

次に、可視セルにのみ貼り付ける方法です。

こちらはセルが非表示かどうかを判定しているため長いコードになっています。

Sub test2()
 
    Dim dob As Object
    Dim clp_ary As Variant
    Dim clp_txt As String
    Dim i As Long
    Dim lj As Long
    Dim dat_num As Long
    Dim end_flg As Boolean
    Dim clp_col_ary As Variant
    Dim k As Long
    Dim cj As Long
    Dim total_col_offset As Long
    
    Application.ScreenUpdating = False
 
    Set dob = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    dob.GetFromClipboard
    If Not dob.GetFormat(1) Then
        MsgBox "中止します。" & vbCrLf _
             & "貼付できるのは、文字データのみです。" & vbCrLf _
             & "(Excelのセル、画像などは貼付不可)" _
             , _
             , "PastInFltr"
        Exit Sub
    End If
     
    clp_txt = dob.GetText
    '行方向の分割
    clp_ary = Split(clp_txt, vbCrLf)
    If vbCrLf = Right(clp_txt, 1) _
        Or vbLf = Right(clp_txt, 1) Then
        dat_num = UBound(clp_ary)
    Else
        dat_num = UBound(clp_ary) + 1
    End If
     
    end_flg = False
    For i = 0 To dat_num - 1
        lj = 0
        '行方向
        If ActiveCell.EntireRow.Hidden Then
            Do While ActiveCell.Offset(lj, 0).EntireRow.Hidden
                lj = lj + 1
            Loop
             
            ActiveCell.Offset(lj, 0).Select
        End If
        '列方向の分割
        clp_col_ary = Split(clp_ary(i), vbTab)
        total_col_offset = 0
        For k = 0 To UBound(clp_col_ary)
            cj = 0
            If k = 0 Then
                ActiveCell.Value = clp_col_ary(k)
            Else
                If ActiveCell.EntireColumn.Hidden Then
                    Do While ActiveCell.Offset(lj, cj).EntireColumn.Hidden
                        cj = cj + 1
                        total_col_offset = total_col_offset + 1
                    Loop
                End If
                ActiveCell.Offset(0, cj).Select
                
                ActiveCell.Value = clp_col_ary(k)
            End If
            ActiveCell.Offset(0, 1).Select
            total_col_offset = total_col_offset + 1
        Next
        
        '次のセル位置へ
        ActiveCell.Offset(1, -total_col_offset).Select
    Next i
 
    Application.ScreenUpdating = True
 
End Sub

Sub test2()

Dim dob As Object

Dim clp_ary As Variant

Dim clp_txt As String

Dim i As Long

Dim lj As Long

Dim dat_num As Long

Dim end_flg As Boolean

Dim clp_col_ary As Variant

Dim k As Long

Dim cj As Long

Dim total_col_offset As Long

Application.ScreenUpdating = False

Set dob = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

dob.GetFromClipboard

If Not dob.GetFormat(1) Then

MsgBox "中止します。" & vbCrLf _

& "貼付できるのは、文字データのみです。" & vbCrLf _

& "(Excelのセル、画像などは貼付不可)" _

, _

, "PastInFltr"

Exit Sub

End If

clp_txt = dob.GetText

'行方向の分割

clp_ary = Split(clp_txt, vbCrLf)

If vbCrLf = Right(clp_txt, 1) _

Or vbLf = Right(clp_txt, 1) Then

dat_num = UBound(clp_ary)

Else

dat_num = UBound(clp_ary) + 1

End If

end_flg = False

For i = 0 To dat_num - 1

lj = 0

'行方向

If ActiveCell.EntireRow.Hidden Then

Do While ActiveCell.Offset(lj, 0).EntireRow.Hidden

lj = lj + 1

Loop

ActiveCell.Offset(lj, 0).Select

End If

'列方向の分割

clp_col_ary = Split(clp_ary(i), vbTab)

total_col_offset = 0

For k = 0 To UBound(clp_col_ary)

cj = 0

If k = 0 Then

ActiveCell.Value = clp_col_ary(k)

Else

If ActiveCell.EntireColumn.Hidden Then

Do While ActiveCell.Offset(lj, cj).EntireColumn.Hidden

cj = cj + 1

total_col_offset = total_col_offset + 1

Loop

End If

ActiveCell.Offset(0, cj).Select

ActiveCell.Value = clp_col_ary(k)

End If

ActiveCell.Offset(0, 1).Select

total_col_offset = total_col_offset + 1

'次のセル位置へ

ActiveCell.Offset(1, -total_col_offset).Select

Next i

Application.ScreenUpdating = True

End Sub

上記コードを実行すると可視セルにのみ貼り付けることができます。

実行結果

可視セルのみコピーされ、可視セルのみに貼り付けられていますね。

おわりに

今回ご紹介した方法で業務が時短されれば幸いです。

以下のサイトを参考にさせて頂きました。

https://ponseblog.com/excel/pastinfltr