【補足欄が足りなかったため、こちらで再質問させていただきます。】 Excelの転記マクロについて、教

【補足欄が足りなかったため、こちらで再質問させていただきます。】

Excelの転記マクロについて、教えてください。

AAAAというExcelのデータがあり
A列に、支店名コード（４桁）があり、支店ごとの情報がＸ列まで
入っています。

①AAAA.exｃｅｌ　（データはＡ列からＸ列まで）

支店名　　売上　　　最終値引き ・・・・・
0001 50000 4500
0002 60000 12000
　・
　・
　
このデータを支店名でフィルターをかけて、支店別のExcelに見出しなし、かつ
支店名を除いたデータを転記したいと考えています。

例えばですが・・[0001支店.excel]　にデータを貼り付けたいのですが
支店別のExcelには、A-C列に別の情報が入っていて、
D列から、　売上　最終値引き・・・　の見出しがあるので
D列（２行目）から、フィルターをかけた可視セルの情報を値貼付けしたいです。
（Ａ列の支店名は不要）

どうしても支店名がコピーされてしまうので、困っています。
どなたか教えていただけると助かります！

マクロは、下記の通りです。

Sub TEST()

Dim Wb1 As Workbook
Dim Wb2 As Workbook

'現在開いているファイルを変数格納
Set Wb1 = ActiveWorkbook

'別ファイルを開く
Workbooks.Open "D:\Users\△△\0001支店.xlsx"
Set Wb2 = ActiveWorkbook


'フィルターでデータ抽出
Wb1.Sheets("S1").Range("A1").CurrentRegion.AutoFilter _
Field:=1, _
Criteria1:="0001"

If WorksheetFunction.Subtotal(3, Range("A:A")) > 1 Then

'フィルター抽出結果を別ファイルへ転記
With Wb1.Sheets("S1").Range("B1:X1").CurrentRegion
.Resize(.Rows.Count - 1).Offset(1, 0).Copy
Wb2.Sheets("TEST").Range("D7").PasteSpecial Paste:=xlPasteValues

End With
End If

'オートフィルタを解除
Range("A1").AutoFilter
End Sub

No.2 ベストアンサー 回答者： fujillin 回答日時： 2023/09/27 21:33

No1です。

ごめんなさい。
見落としていました。　No1の一部に誤りがありました。

＞.Resize(.Rows.Count - 1).Offset(1, 0).Copy
行数は「.Rows.Count」となっているので、行数オーバーということはないですね。
（ Rows.Count と勘違いしてしまいました。）
大変失礼をいたしました。

CurrentRegionでA列迄を含んでいるので、列方向も同じことを行えば、1列分範囲を締められます。

少し発想を変えてもよければ、
With Wb1.Sheets("S1").Range("B1:X1").CurrentRegion
　Intersect(.Cells, .Offset(1, 1)).Copy
　　・・・・・
とすることでB2セル以降をコピーできると思います。

失礼いたしました。

この回答へのお礼

再度のご回答ありがとうございます。また、手順を整理しきれない状態での質問、大変失礼いたしました。
教えていただいた内容で、動かしてみたところ支店コードがない状態でコピーできました。この転記作業のマクロを考えるのに何時間も費やしていたので、とても嬉しいです。ありがとうございました。

お礼日時：2023/09/28 10:19

No.4 回答者： tatsumaru77 回答日時： 2023/09/28 10:20

No3です。

提示したマクロに誤りがありました。無視してください。
失礼しました。
No2の方のマクロが参考になるかと。

この回答へのお礼

見ていただいて、ありがとうございます！

お礼日時：2023/09/29 08:42

No.3 回答者： tatsumaru77 回答日時： 2023/09/28 10:11

以下のようにしてください。

Sub TEST()

Dim Wb1 As Workbook
Dim Wb2 As Workbook

'現在開いているファイルを変数格納
Set Wb1 = ActiveWorkbook

'別ファイルを開く
Workbooks.Open "D:\Users\△△\0001支店.xlsx"
Set Wb2 = ActiveWorkbook


'フィルターでデータ抽出
Wb1.Sheets("S1").Range("A1").CurrentRegion.AutoFilter _
Field:=1, _
Criteria1:="0001"
If WorksheetFunction.Subtotal(3, Wb1.Sheets("S1").Range("A:A")) > 1 Then

'フィルター抽出結果を別ファイルへ転記
Wb1.Sheets("S1").Range("B2:X2").Resize(Wb1.Sheets("S1").Rows.Count - 1).Copy
Wb2.Sheets("TEST").Range("D7").PasteSpecial Paste:=xlPasteValues
With Wb1.Sheets("S1").Range("A1").CurrentRegion
.Resize(.Rows.Count - 1).Offset(1, 1).Copy
Wb2.Sheets("TEST").Range("D7").PasteSpecial Paste:=xlPasteValues

End With
End If

'オートフィルタを解除
Wb1.Sheets("S1").Range("A1").AutoFilter
End Sub

No.1 回答者： fujillin 回答日時： 2023/09/27 10:59

こんにちは

＞どうしても支店名がコピーされてしまうので、困っています。
前回も書きましたけれど・・
　支店名の列をはずしてコピーすればよいだけ
でしょう。

＞With Wb1.Sheets("S1").Range("B1:X1").CurrentRegion
＞.Resize(.Rows.Count - 1).Offset(1, 0).Copy
Range("B1:X1") でＢ列からを指定したつもりでも、CurrentRegionを取ればＡ列を含んだ範囲になると推測されます。
（Ａ列が全て空白なら拡張されませんけれど、そうではないでしょうから）

＞.Resize(.Rows.Count - 1)
さらにそれを最終行まで拡張しているので、前のCurrentRegionすら何をしたいのか不明になってきます。

前回も書きましたように、「なさりたいこと」を実現する手順をきちんと整理すれば、質問などせずとも解決できるはず。
2行目から最終行までまとめてコピーしたいのなら、
　Wb1.Sheets("S1").Range("B2:X2").Resize(.Rows.Count - 1).Copy
だけですむはずです。
（With構文も不要になるでしょう）

ただし、
＞Wb2.Sheets("TEST").Range("D7").PasteSpecial Paste:=xlPasteValues
7行目以降にペーストしようとしているけれど、コピー内容を考ええば行数が足りないはず。
手操作で同様のことをやってもエラーになると思いますけれど？？


※ やりたいことを整理して、それをきちんとコードになるように記述しましょう。
※ 自分が書いたコードがどのような処理をしているのか、じっくりと考えてみましょう。
頭の中で「できるはず」ではなく、実際に手操作でやってみれば、すぐにわかると思います。