エクセルマクロ オートフィルターでで選択コピー

シート1のA列からZ列まである表でオートフィルターをかけて見出し以外をコピーしたい。
L列で空白以外でフィルターをかけます。
見出し以外のA～K列、S、U、V、W、Z列の値をコピーしたい。
コピーした値は別シートのシート2に左から詰めて貼り付けたい。
シート1のA～K列→シート2のA2からK列に貼り付け。
シート1のS列→シート2のL2へ貼り付け。
シート1のU~W列→シート2のM２から貼り付け。
シート1のZ列→シート2のP2へ貼り付け。

上記が終われば、次にシート1のR列で絞り込み、
シート2の先に貼り付けた下側に同じように貼り付けたい。

フィルターで絞り込む列が、1回1回変わります。
絞り込んだ列は都度変わりますが、貼り付ける場所はL列と決まっています。
絞り込んだ行に対してA～K、S、U、V、W、Z列の値を貼り付けたいです。

ただ絞り込んだときに0行だったり1行だったりします。
0行の場合はないと表示させたいです。




マクロのコードを教えてください。
どうかよろしくお願いします。

No.2 ベストアンサー 回答者： tatsumaru77 回答日時： 2022/04/18 14:40

同じ行がコピーされても問題ないと理解しました。

以下のマクロを標準モジュールに登録してください。
フィルターの列は、L,R,Xの順に行っています。


Option Explicit

Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim row2 As Long
Public Sub 空白列以外をコピー()
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
sh2.Rows("2:" & Rows.count).ClearContents
row2 = 2
filter_copy ("L")
filter_copy ("R")
filter_copy ("X")
MsgBox ("完了")
End Sub

Private Sub filter_copy(ByVal col As String)
Dim row1 As Long
Dim maxrow As Long
Dim count As Long
count = 0
maxrow = sh1.Cells(Rows.count, "A").End(xlUp).row 'sheet1 A列の最大行取得
For row1 = 2 To maxrow
If sh1.Cells(row1, col).Value <> "" Then
sh2.Cells(row2, "A").Resize(1, 11).Value = sh1.Cells(row1, "A").Resize(1, 11).Value
sh2.Cells(row2, "L").Value = sh1.Cells(row1, "S").Value
sh2.Cells(row2, "M").Value = sh1.Cells(row1, "U").Value
sh2.Cells(row2, "N").Value = sh1.Cells(row1, "V").Value
sh2.Cells(row2, "O").Value = sh1.Cells(row1, "W").Value
sh2.Cells(row2, "P").Value = sh1.Cells(row1, "Z").Value
row2 = row2 + 1
count = count + 1
End If
Next
If count = 0 Then
MsgBox (col & "列該当データなし")
End If
End Sub

この回答へのお礼

ありがとうございます！

お礼日時：2022/04/19 09:43

No.1 回答者： tatsumaru77 回答日時： 2022/04/18 14:12

L列が空白でなく、R列も空白でない行があると、その行は２回コピーされますが、それで良いのでしょうか？

この回答へのお礼

L列を空白以外で絞りその時のデータをそれぞれ貼り付け、
その後、フィルターを解除し、次にR列を空白以外で絞りデータをコピペ、
それからさらにフィルターを解除し、X列を空白以外で絞りこみ・・・以下同じ。といった感じです。
L列で空白以外を絞ったときと、R列を空白以外で絞ったときは6行目の値がかぶる形になります。
それぞれの絞った列ごとに値を抜き出したいです。

お礼日時：2022/04/18 14:22