Excel
tool

【Excel】見えているセルにだけ貼り付けるマクロ

Excel
2023.09.30

Excelでフィルタをしたり、行を非表示にした状態で、見えているセルにだけデータを貼り付けたいと思ったことはありませんか？
本投稿では、これを実現するマクロを紹介します。

普通に貼り付けると．．．

連番１～５のデータがある状態で、連番３の行をフィルタで隠します。

ここで、連番２の位置から３行分のデータを貼り付けると、２行しか貼られていないように見えます。
フィルタを解除すると、隠れていた（連番３の）行にもデータが貼り付けられています。

見えているセルにだけ貼ってほしい。。。


マクロを使うと．．．

今回紹介するマクロを使うと、フィルタをしたり行を非表示にしていても、見えている行にだけデータを貼り付けできます。 (^^)v


PONSEは職場で、フィルタで見えているセルにだけ連番を振るために、このマクロを使いました。
使いどころは他にもありそうです。よろしければ活用ください。

制限事項

  • 当マクロは、WindowsのExcelで動作確認しています。
    Macでは改行コードの違いにより、正しく動作しない可能性があります。
  • 当マクロは、テキストエディタ上のデータを、Excelに貼り付ける仕様です。
    Excelや他のアプリから貼り付ける場合、一旦テキストエディタを経由する必要があります。
    （同じブック内のセルでも、直接貼り付けできません）
  • ”テキストエディタを経由する” ひと手間はありますが、操作は簡単です。
    詳細は、後述する「使い方」を参照ください。
  • 当マクロで貼り付けできるのは、一度に１列だけです。
    複数の列を貼り付けたい場合、1列ずつ複数回操作してください。
  • セル内で改行しているデータは正しく貼り付けできません。

使い方

使用例として、Excelでフィルタを適用している表に、別の場所にあるセルからデータをコピーします。

操作は、次の５ステップです。

  1. マクロのブックを起動
  2. テキストエディタを起動
  3. Excelのデータをコピー
  4. テキストエディタに貼り付け
  5. テキストエディタのデータをコピー
  6. Excel上で貼付先のセルを選択して、マクロを実行

マクロのブックを起動

マクロが入ったブックを開きます。
ブックは こちら からダウンロードできます。

次の注意が表示された場合は、「編集を有効にする」をクリックしてください。

”注意－インターネットから入手したファイルは、ウイルスに感染している可能性があります。編集する必要がなければ、保護ビューのままにしておくことをお勧めします。”

次のメッセージが表示された場合は、一旦ブックを閉じて下さい。
ダウンロードしたブックに対して、マクロの実行を許可する必要があります。

”このファイルのソースが信頼できないため、Microsoftによりマクロの実行がブロックされました。”

下記の投稿を参考にして、マクロの実行を許可してください。

【簡単解決】マクロがブロックされて動かない

テキストエディタを起動

お好みのテキストエディタを起動します。

Windows標準のメモ帳でよろしければ、次の手順で起動します。

  • Windowsキーを押したままRを押す。
  • 「ファイル名を指定して実行」画面が表示されます。
  • [名前]に notepad を入力して、「OK」ボタンを押す。
  • メモ帳が起動します。

Excelのデータをコピー

Excel上で、貼り付けたいデータを選択。（列の選択は１列まで）
Ctrl＋Cでコピーします。

テキストエディタに貼り付け

テキストエディタ上でCtrl＋Vを押して、コピーしたデータを貼り付けます。

テキストエディタのデータをコピー

テキストエディタに貼り付けたデータを、Ctrl＋Ａを押してそのまま全て選択。
続いて、Ctrl＋Cでコピーします。

Excel上で貼付先のセルを選択して、マクロを実行

Excel上で、貼り付け先のセルを選択。

Alt＋F8を押すと、「マクロ」ダイアログが表示されます。
リストの「PastInFltr」を選択して、「実行」ボタンを押します。

以上です。
表のフィルタを解除して、思った通りにデータが貼り付けられていることを確認ください。

ダウンロード

アイコン

PastInFltr_v100.xlsm

1 ファイル 17 KB
ダウンロード

ソースコード

以下にソースコードを掲載します。
ダウンロードできない環境などで、ご使用ください。

Sub PastInFltr()

    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

    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
                If Rows.Count < (ActiveCell.Row + lj) Then
                    end_flg = True
                    Exit Do
                End If
            Loop
            If end_flg Then
                Exit For
            End If
            
            ActiveCell.Offset(lj, 0).Select
        End If
        
        ActiveCell.Value = clp_ary(i)
        
        If Rows.Count <= ActiveCell.Row Then
            end_flg = True
            Exit For
        End If

        ActiveCell.Offset(1, 0).Select
    Next i

    If end_flg And i < (dat_num - 1) Then
        MsgBox "中止します。" & vbCrLf _
             & "貼付範囲がExcelの最大行数を超えました。"
        Exit Sub
    End If

    Application.ScreenUpdating = True

End Sub

今回の投稿は以上です。お疲れさまでした！

コメント

タイトルとURLをコピーしました