複数シートのデータを別シートの違う列にコピーする方法

VBAを使ってセルのデータを転記しています。

シート1～3のZ列に"対象"と書かれた列のみを、シート4に転記します。
全シート共通で1～6行目はタイトル行で、データは7行目以降に記入されています。
A列には必ずデータが入っていますが、B～U列には空白のセルもあります。
転記先のシート4はデータのない最終行から書き込みを始めます。

転記元と先でフォーマットが同じであればFor Nextでいけそうなのですが、
下記の通り列がずれているため思い通りにできません。

コピーしたい列：シート1、シート2、シート3（どれも共通）
A～B列、F～U列

貼り付けたい列：シート4
A～D列、F～S列

それぞれこんな風になります。
A　→　A
B　→　B
F　→　C
G　→　D
H　→　F
I　→　G
～省略～
U　→　S

どうすればうまく転記できるでしょうか。

質問者からの補足コメント

• すみませんが、コピーしたい列が1列増えました。
  
  コピーしたい列：シート1、シート2、シート3（どれも共通）
  A～C列、F～U列
  
  貼り付けたい列：シート4
  A～E列、G～T列
  
  それぞれこんな風になります。
  A　→　A
  B　→　B
  C　→　C
  F　→　D
  G　→　E
  H　→　G
  I　→　H
  ～省略～
  U　→　T

    補足日時：2017/11/15 14:55

No.11 ベストアンサー 回答者： tom04 回答日時： 2017/11/15 18:07

No.2・3・7です。

もう一度コードを最初からやり替えてみました。

Sub Sample2()
Dim k As Long, lastRow As Long
Dim myRow As Long, wS As Worksheet
Set wS = Worksheets(4)
Application.ScreenUpdating = False
For k = 1 To 3
With Worksheets(k)
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Rows(6).AutoFilter field:=Range("Z1").Column, Criteria1:="対象"
If .Cells(Rows.Count, "A").End(xlUp).Row > 6 Then
myRow = wS.Cells(Rows.Count, "A").End(xlUp).Row + 1
Range(.Cells(7, "A"), .Cells(lastRow, "C")).Copy
wS.Cells(myRow, "A").PasteSpecial Paste:=xlPasteValues
Range(.Cells(7, "F"), .Cells(lastRow, "G")).Copy
wS.Cells(myRow, "D").PasteSpecial Paste:=xlPasteValues
Range(.Cells(7, "H"), .Cells(lastRow, "U")).Copy
wS.Cells(myRow, "G").PasteSpecial Paste:=xlPasteValues
End If
.AutoFilterMode = False
End With
Next k
Application.CutCopyMode = False
Application.ScreenUpdating = True
wS.Activate
wS.Cells(Rows.Count, "A").End(xlUp).Select
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

できました！
ありがとうございます。

ちなみに貼り付ける際の先頭行のA列に
”売上一覧 2017-11-15”
と入れるには
"売上一覧 " & Format(Date, "yyyy-mm-dd")
と記述すればいいと思うのですが、
myRow = wS.Cells(Rows.Count, "A").End(xlUp).Row + 1
の行の下に入れればいいでしょうか？
その際のセルのセットの仕方がよく分からず困っています。

お礼日時：2017/11/15 21:44

No.12 回答者： tom04 回答日時： 2017/11/15 22:16

＞ちなみに貼り付ける際の先頭行のA列に

＞”売上一覧 2017-11-15”
＞と入れるには

このmyRow　はデータを貼り付ける最初の行番号取得なので、myRow　を取得する前に入れてください。
自分の投稿したコードを見ると、For～Next内にmyRowを入れていますね。
単純にその前に入れてしまうとSheet（3つ）分同じものが入ってしまいます。

＞Application.ScreenUpdating = False
の次に

＞wS.Cells(Rows.Count, "A").End(xlUp).Offset(1) = Format(Date, "yy-mm-dd")

の1行を追加してみてください。m(_ _)m

この回答へのお礼

できました！！

コピー元と先はの列名は変数で＋とかせずに、絶対値で指定したほうがよかったのですね。
ありがとうございます。

お礼日時：2017/11/18 23:04

No.10 回答者： GooUserラック 回答日時： 2017/11/15 17:36

No.9 の修正です。

--------------------------------------------------------------------------------
Sub データコピー()
Dim シート番号 As Long
Dim 次行 As Long
Application.ScreenUpdating = False
For シート番号 = 1 To 3
Sheets(4).Select
次行 = Cells(Rows.Count, 1).End(xlUp).Row + 1
If 次行 < 7 Then 次行 = 7
Range("A" & 次行 & ":E" & Rows.Count & ",G" & 次行 & ":T" & Rows.Count).MergeCells = False
Sheets(シート番号).Select
Cells.AutoFilter Field:=26, Criteria1:="対象"
Range("A7:C" & Rows.Count & ",F7:G" & Rows.Count).Copy
Sheets(4).Range("A" & 次行).PasteSpecial Paste:=xlPasteValues
Range("H7:U" & Rows.Count).Copy
Sheets(4).Range("G" & 次行).PasteSpecial Paste:=xlPasteValues
Cells.AutoFilter
Next
Application.ScreenUpdating = True
Sheets(4).Select
Range("A7").Select
End Sub
--------------------------------------------------------------------------------

この回答へのお礼

回答ありがとうございます。

しかし、実行時エラー1004　が出てしまいます。
デバックの黄色行も
Sheets(4).Range("A" & 次行).PasteSpecial Paste:=xlPasteValues
のままでした。

どうすれば良いでしょうか。

お礼日時：2017/11/15 17:46

No.9 回答者： GooUserラック 回答日時： 2017/11/15 17:30

No.8 追記

貼り付ける前に、貼り付け先に結合セルが有った場合、結合を解除するものを作ってみました。お試しください。
--------------------------------------------------------------------------------
Sub データコピー()
Dim シート番号 As Long
Dim 次行 As Long
Application.ScreenUpdating = False
For シート番号 = 1 To 3
Sheets(4).Select
次行 = Cells(Rows.Count, 1).End(xlUp).Row + 1
Range("A" & 次行 & ":E" & Rows.Count & ",G" & 次行 & ":T" & Rows.Count).MergeCells = False
Sheets(シート番号).Select
If 次行 < 7 Then 次行 = 7
Cells.AutoFilter Field:=26, Criteria1:="対象"
Range("A7:C" & Rows.Count & ",F7:G" & Rows.Count).Copy
Sheets(4).Range("A" & 次行).PasteSpecial Paste:=xlPasteValues
Range("H7:U" & Rows.Count).Copy
Sheets(4).Range("G" & 次行).PasteSpecial Paste:=xlPasteValues
Cells.AutoFilter
Next
Application.ScreenUpdating = True
Sheets(4).Select
Range("A7").Select
End Sub

--------------------------------------------------------------------------------

No.8 回答者： GooUserラック 回答日時： 2017/11/15 16:58

No.6 のお礼について

シート4の7行目以降にセル結合されたものはありませんか？

この回答へのお礼

書式の検索を使って探してみましたが、結合されたセルはありませんでした。
他になにか見直すところはありますか？

お礼日時：2017/11/15 17:20

No.7 回答者： tom04 回答日時： 2017/11/15 16:20

No.2です。

＞コピーするときに値貼り付けしたいのですが

前回投稿したコードの
＞Range(.Cells(7, "A"), .Cells(lastRow, "B")).SpecialCells(xlCellTypeVisible).Copy _
wS.Cells(myRow, "A")

は
見た目は2行になっていますが実は1行のコードです。
VBE画面上で1行に表示してしまうと、画面をスクロールしなくてはならなくなるので
アンダーバー（_）を入れて表示しています。

上記の行を
Range(.Cells(7, "A"), .Cells(lastRow, "B")).SpecialCells(xlCellTypeVisible).Copy
wS.Cells(myRow, "A").PasteSpecial Paste:=xlPasteValues

のように2行にしてみてください。

※　他の行（コピー＆ペーストの行）もすべて同じです。m(_ _)m

この回答へのお礼

ありがとうございます！値貼り付けできました。

3シート目の対象行H～U行がコピーの切り取り範囲になったまま
貼り付けシートのF～S列が選択されたままになっているのは、
手動で解除してあげる必要がありますか？

また、質問の補足欄に
＜すみませんが、コピーしたい列が1列増えました。＞
という追加のお願いがあり、こちらはどこを書き換えたら良いでしょうか？

お礼日時：2017/11/15 16:45

No.6 回答者： GooUserラック 回答日時： 2017/11/15 15:19

No.4 のお礼について

エラーの件見落としました。どこでエラーしていますか？

この回答へのお礼

実行時エラー　'1004'
コピー領域と貼り付け領域のサイズが違うため、貼り付けることができません。
と出ます。
デバックでは
Sheets(4).Range("A" & 次行).PasteSpecial Paste:=xlPasteValues
の行が黄色になっています。

お手数おかけしてすみません。

お礼日時：2017/11/15 16:50

No.5 回答者： GooUserラック 回答日時： 2017/11/15 15:12

No.4 のお礼について

その通りです。と言いたいのですが、今度はF列を空けるのですよね、それでしたら「Sheets(4).Range("F" & 次行).PasteSpecial Paste:=xlPasteValues」も「Sheets(4).Range("G" & 次行).PasteSpecial Paste:=xlPasteValues」にしないとダメです。

No.4 回答者： GooUserラック 回答日時： 2017/11/15 13:47

それでは、こんなものはいかがでしょうか？

--------------------------------------------------------------------------------
Sub データコピー()
Dim シート番号 As Long
Dim 次行 As Long
Application.ScreenUpdating = False
For シート番号 = 1 To 3
Sheets(シート番号).Select
次行 = Sheets(4).Cells(Rows.Count, 1).End(xlUp).Row + 1
If 次行 < 7 Then 次行 = 7
Cells.AutoFilter Field:=26, Criteria1:="対象"
Range("A7:B" & Rows.Count & ",F7:G" & Rows.Count).Copy
Sheets(4).Range("A" & 次行).PasteSpecial Paste:=xlPasteValues
Range("H7:U" & Rows.Count).Copy
Sheets(4).Range("F" & 次行).PasteSpecial Paste:=xlPasteValues
Cells.AutoFilter
Next
Application.ScreenUpdating = True
Sheets(4).Select
Range("A7").Select
End Sub
--------------------------------------------------------------------------------

この回答へのお礼

RangeクラスのPasteSpecialメソッドが失敗しました
とエラーになってしました。
また、コピーしたい列が増えた件については、
Range("A7:B" & Rows.Count & ",F7:G" & Rows.Count).Copy
を
Range("A7:C" & Rows.Count & ",F7:G" & Rows.Count).Copy
にすればよいですか？

お礼日時：2017/11/15 14:57

No.3 回答者： tom04 回答日時： 2017/11/14 20:52

No.2です。

前回はちょっと手抜きをしていました。

Sub Sample2()
Dim k As Long, lastRow As Long
Dim myRow As Long, wS As Worksheet
Set wS = Worksheets(4)
For k = 1 To 3
With Worksheets(k)
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Rows(6).AutoFilter field:=Range("Z1").Column, Criteria1:="対象"
If .Cells(Rows.Count, "A").End(xlUp).Row > 6 Then
myRow = wS.Cells(Rows.Count, "A").End(xlUp).Row + 1
Range(.Cells(7, "A"), .Cells(lastRow, "B")).SpecialCells(xlCellTypeVisible).Copy _
wS.Cells(myRow, "A")
Range(.Cells(7, "F"), .Cells(lastRow, "G")).SpecialCells(xlCellTypeVisible).Copy _
wS.Cells(myRow, "C")
Range(.Cells(7, "H"), .Cells(lastRow, "U")).SpecialCells(xlCellTypeVisible).Copy _
wS.Cells(myRow, "F")
End If
.AutoFilterMode = False
End With
Next k
MsgBox "完了"
End Sub

とした方が良いと思います。m(_ _)m

この回答へのお礼

ありがとうございます！
コピー元の列がこうなったらコピー先の列を＋１してetcとかやらないほうがいいんですね。

もう1点。
コピーするときに値貼り付けしたいのですが、
wS.Cells(myRow, "A").PasteSpecial Paste:=xlPasteValues
と記述したら構文エラーになってしまいました。
.PasteSpecial Paste:=xlPasteValues
は使えないのでしょうか。

お礼日時：2017/11/15 12:30