準・究極の選択

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

解決済

  • 質問者：yokyok954
  • 質問日時：
  • 回答数：12件

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
    通報する
通報する

この質問への回答は締め切られました。

質問の本文を隠す

A 回答 (12件中1～10件)

No.1

念の為確認します。


・シート４にもタイトル行は存在するのですね
・データは並べ替えたりしてはダメですよね
・データは何行ほどあるのでしょうか？
・シート４のＥ列は何もしないで残すわけですよね
    • good
    • 0
    • 件
通報する
この回答へのお礼

・シート４にもタイトル行は存在するのですね
　→はい
・データは並べ替えたりしてはダメですよね
　→シート毎にそのままの状態が良いです
・データは何行ほどあるのでしょうか？
　→シート1～3は500行、シート4は1500行ほどあります。
・シート４のＥ列は何もしないで残すわけですよね
　→はい、空白のままです

宜しくお願いします。

通報する
お礼日時：2017/11/15 12:28

参考程度に

No.2

  • 回答者： tom04
  • 回答日時：

こんばんは！



Sub Sample1()
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")).Copy wS.Cells(myRow, "A")
Range(.Cells(7, "F"), .Cells(lastRow, "G")).Copy wS.Cells(myRow, "C")
Range(.Cells(7, "H"), .Cells(lastRow, "U")).Copy wS.Cells(myRow, "F")
End If
.AutoFilterMode = False
End With
Next k
MsgBox "完了"
End Sub

※　細かい検証はしていませんので
列が違っていたらごめんなさい。m(_ _)m
    • good
    • 0
    • 件
通報する

参考程度に

No.3

  • 回答者： tom04
  • 回答日時：

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
    • good
    • 0
    • 件
通報する
この回答へのお礼

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

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

通報する
お礼日時：2017/11/15 12:30

No.4

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


--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
    • good
    • 0
    • 件
通報する
この回答へのお礼

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.5

No.4 のお礼について



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

No.6

No.4 のお礼について



エラーの件見落としました。どこでエラーしていますか？
    • good
    • 0
    • 件
通報する
この回答へのお礼

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

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

通報する
お礼日時：2017/11/15 16:50

参考程度に

No.7

  • 回答者： tom04
  • 回答日時：

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
    • good
    • 0
    • 件
通報する
この回答へのお礼

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

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

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

通報する
お礼日時：2017/11/15 16:45

No.8

No.6 のお礼について



シート4の7行目以降にセル結合されたものはありませんか？
    • good
    • 0
    • 件
通報する
この回答へのお礼

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

通報する
お礼日時：2017/11/15 17:20

No.9

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

--------------------------------------------------------------------------------
    • good
    • 0
    • 件
通報する

No.10

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
--------------------------------------------------------------------------------
    • good
    • 0
    • 件
通報する
この回答へのお礼

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

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

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

通報する
お礼日時：2017/11/15 17:46

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう！

Q質問する（無料）

ページトップページトップ

Q質問する（無料）

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

おすすめ情報