VBA:オートフィルで表示されている部分にだけ、 別シートの値を貼り付けたい。

Question

前提・実現したいこと

オートフィルで表示されている部分にだけ、別シートの値を貼り付けたい。

1）Sheet1シートのA1セルから下方向へ、値が入っている範囲をコピーする
2）Sheet2シートのオートフィルターが掛かったセル範囲のうち、
見えているセル範囲の1列目から、下方向へ順に貼り付ける
※両シートともに、タイトル行はございません
※A列の項目数は状況により異なります

---

【前提】
■Sheet1

A	B	C
1月1日
1月2日
1月3日

■Sheet2

A	B	C
	あああ
	いいい
	ううう
	あああ
	いいい
	ううう
	あああ
	いいい
	ううう

■Sheet2（オートフィル済）

A	B	C
	あああ
	あああ
	あああ

---

【実現したいこと】
■Sheet2（データ貼り付け後にオートフィル解除後）

A	B	C
1月1日	あああ
	いいい
	ううう
1月2日	あああ
	いいい
	ううう
1月3日	あああ
	いいい
	ううう

---

該当のソースコード

Sub
    Dim rng1 As Range
    Dim rng2 As Range
    Dim InputRng As Range
    Dim OutRng As Range
    xTitleId = "KutoolsforExcel"
    Set InputRng = Application.Selection
    Set InputRng = Application.InputBox("Copy Range :", xTitleId, InputRng.Address, Type:=8)
    Set OutRng = Application.InputBox("Paste Range:", xTitleId, Type:=8)
    For Each rng1 In InputRng
        rng1.Copy
        For Each rng2 In OutRng
            If rng2.EntireRow.RowHeight > 0 Then
                rng2.PasteSpecial
                Set OutRng = rng2.Offset(1).Resize(OutRng.Rows.Count)
                Exit For
            End If
        Next
    Next
    Application.CutCopyMode = False
    
End Sub

補足情報

https://www.extendoffice.com/ja/documents/excel/2617-excel-paste-to-visible-filtered-cells.html
上記サイトのソースを利用しておりますが、
実行のたびに範囲を選択するのではなく、
値の入っている部分だけをコピーして、sheet2に貼り付けたいです。

当方初心者のため、初歩的なご質問となってしまいますが、
どうぞよろしくお願いいたします。

Comments

[mattuwan]

(例)
Sheet2のA列に、Sheet1のA列の内容を貼り付ける
※A列の項目数は状況により異なる

Sheet1のA列のデータ数とSheet2の入力したいセルの数は必ず同じなのですか？
違う場合はどう取り扱うのでしょう？

[mattuwan]

また、提示の表にはタイトル行がないように見えますが、
どのようなセル範囲をコピーして、
どのようなセル範囲に値のみ貼り付けたいのですか？

例）
1）Sheet1シートのA1セルを含む表範囲の1列目のタイトル行を除くデータを、コピーする
2）Sheet2シートのオートフィルターが掛かったセル範囲のタイトル行を除く見えてるセル範囲の2列目へ上から順に貼り付ける

といったように誰に頼んでも間違いがない手順をまずは考えて、説明してみてください。

[yukiiii]

ご指摘ありがとうございます。

Sheet1のA列のデータ数とSheet2の入力したいセルの数は必ず同じなのですか？
→必ず同じとなります。

どのようなセル範囲をコピーして、
どのようなセル範囲に値のみ貼り付けたいのですか？
→1）Sheet1シートのA1セルから下方向へ、値が入っている範囲をコピーする（タイトル行はない）
　2）Sheet2シートのオートフィルターが掛かったセル範囲のうち、
　　見えているセル範囲の1列目から、下方向へ順に貼り付ける

上記、確かに情報が不足しておりました。
質問内容も修正させていただいたので、ご教示いただけますと幸いです。

Answer 1

オートフィル？

まず本題とは少し外れますが、気になったので指摘させていただきます。

・オートフィル：自動(Auto)でセルに値を埋める(Fill)機能
・オートフィルター：自動(Auto)でセルを絞り込む(Fillter)機能

どちらもExcelに備わっている別々の機能です。
名前が似ていて間違えやすいですが、今回の質問のように「フィルターをかけたセルに値を埋めたい」となると一層わかりずらく混乱の元になりますのでご注意ください。

アドバイス①　ソースを理解する

ネット上で動くと書いてあるソースコードを拾ってきたとしても、それを利用するのであれば何をしているのかわからないまま使うわけにはいきません。
まずは利用するコードについて、それぞれの行で何を処理しているのか把握しましょう。

そのために、たとえば各行にコメントをつけてみるのが一つの手です。
（把握できているようでしたらここは読み飛ばしていただいて問題ありません。）

Sub
    Dim rng1 As Range
    Dim rng2 As Range
    Dim InputRng As Range
    Dim OutRng As Range
    
    xTitleId = "KutoolsforExcel"    'ユーザー入力ダイアログのタイトル表示用
    
    '●入力セル範囲の指定
    '現在の選択範囲を設定　⇒これをユーザー入力時の規定値として表示
    Set InputRng = Application.Selection
    '入力セル範囲をユーザーに入力させる
    Set InputRng = Application.InputBox("Copy Range :", xTitleId, InputRng.Address, Type:=8)
    
    '●出力セル範囲の指定（規定値なし）
    '出力セル範囲をユーザーに入力させる
    Set OutRng = Application.InputBox("Paste Range:", xTitleId, Type:=8)
    
    '入力セル範囲からセルを１つずつ取り出すループ処理
    For Each rng1 In InputRng
        '取り出した入力セルをクリップボードにコピー
        rng1.Copy
        
        '出力セル範囲からセルを１つずつ取り出すループ処理
        For Each rng2 In OutRng
            '取り出した出力セルの高さを判定(フィルタで非表示の項目は高さ0)
            If rng2.EntireRow.RowHeight > 0 Then
                '出力セルにクリップボードの内容を貼り付け
                rng2.PasteSpecial
                
                '出力セル範囲を出力セルの1行下からの範囲に縮小する
                Set OutRng = rng2.Offset(1).Resize(OutRng.Rows.Count)
                
                '出力セルのループを抜ける
                Exit For
            End If
        Next
    Next
    Application.CutCopyMode = False

End Sub

本来はご自身で意味を調べて把握されるほうが身に付くのですが、今回は私のほうでコメント追加させていただきました。

こうしてみると「今回変更したいのはどこの処理で、現状どう処理しているか？」が具体的に見えてきませんか？

アドバイス②　今回やりたいこと

「どこを変えればいいのか？」が見えてきたら、次は「どう変えればいいのか？」です。

今回やりたいことは

値の入っている部分だけをコピー

するように変更したいのですよね。

これを実現するためには「値の入っている部分」を見つけてInputRngに設定してあげる必要がありそうです。

「値の入っている部分」の見つけ方はmattuwanさんのアドバイスにあるソースコード内にヒントがありますので、このソースも１行ずつ何をしているのか把握してみてください。

---

概ね考え方に対するアドバイスとなりましたが、参考になれば幸いです。

Answer 2

VBAもいいですが、この手なら、Excelのワークシート関数で実現可能です。
代入したい値の表には、テーブルにしておきます。
そして、図の様な数式を利用します。

アプローチとしては、COUNTIF関数で、件数を求めますが、範囲をADDRESS関数とROW関数で動的に表現し、INDIRECT関数で、範囲を指定して、あたかも順番が表示されうようになります。
順番が日付をもってくるときのキーになりますので、INDEX関数で一発です。

条件を指定しない場合は、全て上から処理されるので、VBAより勝手が良いと思います。

Answer 3

Sub test()
    Dim rngFrom As Range
    Dim rngTo As Range
    Dim i As Long
    
    'コピー元リストのセル範囲の特定
    With Worksheets("Sheet1")
        Set rngFrom = Application.Range(.Range("A1"), .Cells(.Rows.Count).End(xlUp))
    End With
    
    '貼付先のセル範囲(可視セルのみ対象）の特定
    With Worksheets("Sheet2").AutoFilter.Range
        On Error Resume Next
        Set rngTo = Intersect(.Offset(1), .Columns(1)).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
    End With
    '貼付先が見つからなければ終了
    If rngTo Is Nothing Then Exit Sub
    
    '飛び飛びのセル範囲に貼付
    For i = 1 To rngFrom.Count
        rngFrom(i).Copy rngTo.Areas(i).Cells(1)
    Next
End Sub

こういう場合は、
1）ジャンプ機能（Specialcellsメソッド）で、可視セルを検索し、
2）その飛び飛びの各セル範囲はAreasプロパティで特定できます。
今回の件の場合、「何個目か」が重要なので、
For Each ~ ステートメントではなく、
For ~ ステートメントでループするとよいと思います。

※動作確認してません。上手く動かなかったらお知らせください。
あと、Sheet2シートの方は、「オートフィルター」が掛かっているということは、
「タイトル行が存在する。」という認識でよいでしょうか？
オートフィルターが絶対掛かっているという前提でコードを書いています。
オートフィルターが掛かってないと、エラーになります。
実際の運用時には、事前に、オートフィルターが掛かっているか確認する
コードを書いておいた方がよりよいかと思います。