[[20241221203536]]　『フィルタ絞込みデータを別シートに行追加にて挿入』（ranks）　ページの最後に飛ぶ

『フィルタ絞込みデータを別シートに行追加にて挿入したい』（ranks）

フィルタ絞込みにより絞込まれたデータを別シートに行追加にて挿入したい
のですが、上書き貼付けされてしまいます。

行追加(コピーしたセルの挿入)するにはどのようにすればよいでしょうか。
不足情報ありましたら追加させていただきます。
ご教示の程よろしくお願いいたします。

【やりたいこと】
同じWorksheetに２つのシートがあります。（データは複数行）
・Sheet2のシートでL列に「50」が入力されている場合、A列の文字列を変数に格納します。(forでSheet2の最終行まで繰り返します)
・Sheet1のシートで上記条件でフィルタ絞込みを実施します。
・フィルタ絞込み結果を全てコピーします。
・Sheet2の次行にSheet1でコピーしたものをセルの挿入で貼り付けます。

  ※ここが上書き貼付けされてしまい、下の行の情報が上書きされてしまいます。

   Dim i As Integer
    For i = 1 To Rowmax + 1

    If Worksheets("Sheet2").Cells(i, 13).Value = "50" Then
    'A列の文字列取得
    Item = Worksheets("Sheet2").Cells(i, 12).Value

    'フィルタC列[5]のみに絞込む
    Worksheets("Sheet1").Range("A:AA").AutoFilter Field:=3, Criteria1:="50" 
    'フィルタA列[Sheet2のA列の文字列]のみに絞込む
    Worksheets("Sheet1").Range("A:AA").AutoFilter Field:=1, Criteria1:=Item

'絞り込んだ対象をコピーしSheet2に貼付ける
Worksheets("Sheet1").Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Worksheets("Sheet2").Cells(i + 1, 1)

　　 'フィルタの絞り込み解除

    Worksheets("Sheet1").Range("A:AA").AutoFilter

    End If

    Rowmax = Range("A1").End(xlDown).Row

    Next i

＜使用 Excel：Excel2019、使用 OS：unknown ＞

 読み違いがあるかもしれません。
 Sub test()
     Dim ws1 As Worksheet, ws2 As Worksheet
     Dim lastRow As Long
     Dim RowMax  As Long
     Dim Item
     Dim rng     As Range
     Dim rngBody As Range
     Dim myCount As Long
     Dim i       As Long

     Set ws1 = Worksheets("Sheet1")
     Set ws2 = Worksheets("Sheet2")

     lastRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
     Set rng = ws1.[A1].CurrentRegion
     Set rngBody = Intersect(rng, rng.Offset(1))

     RowMax = ws2.Cells(Rows.Count, "A").End(xlUp).Row

     For i = RowMax To 1 Step -1    '最終行から上に向かって実行する
         If ws2.Cells(i, 13).Value = "50" Then
             Item = ws2.Cells(i, 12).Value

             ws1.Range("A:AA").AutoFilter Field:=3, Criteria1:="50"  '13列目じゃないのですね?
             ws1.Range("A:AA").AutoFilter Field:=1, Criteria1:=Item

             'フィルタされたデータの個数(ただし見出しを含む）エラー回避のため、敢えてこうしています。
             myCount = Application.CountA(rng.Columns(1).SpecialCells(xlCellTypeVisible))
             If myCount > 1 Then
                 'その個数分、行を挿入
                 ws2.Cells(i + 1, 1).Resize(myCount - 1, 1).EntireRow.Insert _
                         Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

                 rngBody.Copy ws2.Cells(i + 1, 1)    'Autofilterの場合、可視セルだけがコピーされます
             End If
             ws1.Range("A:AA").AutoFilter

         End If
     Next
 End Sub

（xyz） 2024/12/22(日) 08:35:23

xyz様

ご教示ありがとうございます。
頂いた例文を基に無事にやりたいことが出来ました。

ありがとうございました。
（ranks） 2024/12/22(日) 14:43:00

コメント返信：

[ 一覧(最新更新順) ]

[[20241221203536]] 『フィルタ絞込みデータを別シートに行追加にて挿入』（ranks） ページの最後に飛ぶ

[[20241221203536]]　『フィルタ絞込みデータを別シートに行追加にて挿入』（ranks）　ページの最後に飛ぶ