マクロでの値貼り付けと参照シートの変更について

Sheet1にあるデータから、
Sheet2のA2:A3にある抽出条件に一致するデータを、
Sheet2のB5に貼りつけるというマクロを作成しました。

【質問①】
貼りつけ自体は上手くいくのですが、
全て貼り付けになるらしく、Sheet1の書式まで貼りつけされてしまいます。
値のみ貼り付けをしたいのですが、どうしたらよろしいでしょうか。

【質問②】
データがあるシートは月ごとに分かれていて、Sheet1～Sheet12まであります。
そこで、Sheets2のA1に参照したいシートの名前を入力したら、
そのシートから参照・データの貼り付けが出来るマクロを作成したいのですが、
どのようにしたらよろしいでしょうか。

質問①か②のどちらかでもかまいませんので、どなたか教えて頂けないでしょうか。
よろしくお願いします。

【マクロ】

Sub Macro１()
Dim myRow1 As Long, myRow2 As Long
myRow1 = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
myRow2 = Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Row
If myRow2 >= 5 Then
Sheets("Sheet2").Range("B5:m" & myRow2).ClearContents
End If
Sheets("Sheet1").Range("b2:m" & myRow1).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet2").Range("A2:A3"), _
CopyToRange:=Sheets("Sheet2").Range("B5"), _
Unique:=False
End Sub

No.1 回答者： WindFaller 回答日時： 2015/04/23 16:07

こんにちは。

①
ふつうは、範囲を決めて貼り付けるのが一般的ですが、あえて書くとすれば、こういう風にはできます。

'//
Sub SheetCopyMacro()
Cells.Copy
Worksheets("Sheet4").Cells.PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End Sub

'///
②
以下は、余計な部分が多いようだけれども、なぜ、そうしているか読めるようでしたから、試してみてください。

どうも、これだけですと、失敗というか、一つだけのコピーになる時があるようです。
CopyToRange:=Sheets("Sheet2").Range("B5")

'//
Sub MacroSample1()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim shName As String
Dim DB As Range　'データベース
Dim Crit As Range　'クライテリア
Dim w As Long
Set sh2 = Worksheets("Sheet2")　'Sheet2を起点とします。
　shName = sh2.Range("A1").Value
　If shName = "" Then MsgBox "A1にシート名がありません。", vbExclamation: Exit Sub
　On Error Resume Next
　Set sh1 = Worksheets(shName) '検索対象シート
　If Err.Number <> 0 Then MsgBox shName & "は見つかりません。", vbExclamation: Exit Sub
　On Error GoTo 0
　Set DB = sh1.Range("A1").CurrentRegion
　w = DB.Columns.Count
　With sh2
　　 With .Range("B5").CurrentRegion
　　　Range("B5", .Cells(.Cells.Count)).ClearContents
　　 End With
　　 Set Crit = .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
　　DB.AdvancedFilter _
　　Action:=xlFilterCopy, _
　　CriteriaRange:=Crit, _
　　CopyToRange:=.Range("B5").Resize(, w), _
　　Unique:=False
　End With
End Sub
'///

この回答へのお礼

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

早速試してみたのですが、
DB.AdvancedFilter _の所で
「抽出した範囲にはフィールド名がないか、または無効なフィールド名です」
と出てきて止まってしまいます。
どうしたら最後まで実行できるか、申し訳ないのですが教えて頂けないでしょうか。
よろしくお願いします。

お礼日時：2015/04/24 21:18

No.2 回答者： WindFaller 回答日時： 2015/04/25 18:42

こんにちは。

#1の回答者です。

>DB.AdvancedFilter _の所で
>「抽出した範囲にはフィールド名がないか、または無効なフィールド名です」

マイクロソフトのサポートをみると、
「データの一覧で、1 つまたは複数の列見出しがない場合、データ レコードのフィールドの情報の欠けている列が存在する場合でも発生します。」
ということです。

これに関しては、直接マクロの問題ではないようで、おそらく、マクロを使わなくても、エラーが出るはずです。しかし、それを補填するために、エラー処理をいくつか施してみました。以下では、特に、※がついている部分です。

一度、手動で試していただければよかったです。手動で通れば、マクロも通りますが、それではマクロ自体があやふやになってしまうので、ひと通りのエラーでカバーできるはずです。

具体的には、一旦、フィールドのタイトルを貼り付けると、そのフィールドの抜けやクリアテリアの違いが出れば、エラーが発生する可能性はあります。そのフィールド項目をたよりに、元データを修正してください。※　
もしも、今回のエラーが発生する場合は、フィールドの項目が完全には貼りつかないはずです。

フィールドの抜けのチェックに関しては、現在は、コメントブロックしています。※※

しかし、簡単なデータ表のチェックはしています。※※※
当然、自分のシート名を設定することはできませんから、「不正」というメッセージが出ます。

今回は入れていませんが、CopyToRange:=.Range("B5").Resize(, w)
の部分の行数をいれないでエラーになる可能性があるとは思えませんが、ないとも言えません。
少なくとも私は一度もエラーを発生したことはありません。

しかし、もし、入れるなら、

エラーチェックの終わる前に、これを入れて、
h = sh1.Range("A1").CurrentRegion.Columns.Count

実行のところで、これを以下に換えます。
CopyToRange:=.Range("B5").Resize(h, w)

'//
Sub MacroSample1()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim shName As String
Dim DB As Range
Dim DbField As Variant
Dim Crit As Range
Dim w As Long
'
''-----ユーザー設定-----
w = 13 'データ列 '既定のデータ列数(A-M列まで）
Set sh2 = Worksheets("Sheet2") '起動シート
''----------------------
''エラーチェック
　shName = sh2.Range("A1").Value
　If shName = "" Then
　　MsgBox "A1にシート名がありません。", vbExclamation
　　Exit Sub
　End If
　On Error Resume Next
　Set sh1 = Worksheets(shName) '検索対象シート
　If Err.Number <> 0 Then
　　MsgBox shName & "は見つかりません。", vbExclamation
　　Exit Sub
　End If
　If StrComp(sh2.Name, shName, 1) = 0 Then
　　 MsgBox "シート名が不正です", vbExclamation
　　 Exit Sub
　End If
　If sh1.Range("A1").CurrentRegion.Rows.Count < 3 Or _
　　sh1.Range("A1").CurrentRegion.Columns.Count < w Then
　　MsgBox "データとして不足しています。", vbExclamation　'※※※
　　Exit Sub
　End If
　On Error GoTo 0
''-------エラーチェックの終わり---------
　With sh1
　 Set DB = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).Resize(, w)
　 Set DbField = DB.Rows(1)
　 ''If WorksheetFunction.CountBlank(DbField) > 0 Then MsgBox "元のデータのフィールドに抜けがある": Exit Sub　'※※
　End With
　
　With sh2
　　'一旦データを消す
　　.Range("B5", .Cells(Rows.Count, 2).End(xlUp)).Resize(, w).ClearContents
　　 '削除しても残骸が残る場合は、こちらに切り替える
　　''.Range("B5", .Cells(Rows.Count, 2).End(xlUp)).Resize(, w).CurrentRegion.ClearContents
　　'クライテリアの設定
　　Set Crit = .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
　　'フィールド名のコピー※
　　DbField.Copy .Range("B5")
　　
　　'アドバンスフィルターの実行
　　DB.AdvancedFilter _
　　Action:=xlFilterCopy, _
　　CriteriaRange:=Crit, _
　　CopyToRange:=.Range("B5").Resize(, w), _
　　Unique:=False
　End With
End Sub
'///

この回答へのお礼

再度のご回答ありがとうございます。
何度も試してみたのですが、データの抽出が上手くいかず、貼りつけが出来ませんでした。
自分で作成したマクロの方は上手く貼りつけが出来ていたので、元データに間違いはないと思うのですが…。特にエラーもかからず、どこが間違っているのかわかりませんでした。
今さらかもしれませんが、このマクロは

元データ　→　B列～M列まであり、空欄･重複なしで100行までデータあり
元データ・F2にある「日付」という項目　→　Sheet2のA2で選択、
元データ・F3～にある日付　→　Sheet2のA3で選択
すると選択した項目･日付のB列~M列のデータをSheet2のB5以降に1行丸ごとコピーする

というものです。
コピーする範囲を設定していないのは、項目が増えるかもしれないからです。

質問②の方は、上手くいきました。
ありがとうございました。

もしよろしければ質問①の方を再度ご回答お願いできないでしょうか。
お手数をおかけして申し訳ありませんが、何卒お願いします。

お礼日時：2015/04/27 02:13

No.3 ベストアンサー 回答者： WindFaller 回答日時： 2015/04/29 00:22

こんばんは。

ちょっと体調を崩しまして、こちらのアクセスするのが遅くなってすみません。

>元データ　→　B列～M列まであり、空欄･重複なしで100行までデータあり
それから、私は、位置関係を間違えていたようですね。細かく指定している分だけ、簡単には出てこないようです。これでは、出るはずはありませんね。全体を一行、一列ずらしました。

>元データ・F2にある「日付」という項目　→　Sheet2のA2で選択、
>元データ・F3～にある日付　→　Sheet2のA3で選択

日付だとは思っていませんでしたが、たぶん、大丈夫なはずです。

とりあえず、そっくり以下を入れ替えてみてください。
うまくいかない場合は、'確認用**のコメントブロックを外して、どこを検索しているか見てください。

それから、
　DbField.Copy .Range("B5")　　'誤作動がなければ、なくても可***
ふつうは要らないはずですが、時々、誤作動するので、入れています。

添付画像で、このようなイメージで作られていることを、ご確認ください。
画像は小さくても、レイアウトや位置関係はわかるかと思います。

'//
Sub MacroSample1()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim shName As String
Dim DB As Range
Dim DbField As Variant
Dim Crit As Range
Dim w As Long
'
''-----ユーザー設定-----
w = 12 'データ列 '既定のデータ列数(B-M列まで）
Set sh2 = Worksheets("Sheet2") '起動シート
''----------------------
''エラーチェック
　shName = sh2.Range("A1").Value
　If shName = "" Then
　　MsgBox "A1にシート名がありません。", vbExclamation
　　Exit Sub
　End If
　On Error Resume Next
　Set sh1 = Worksheets(shName) '検索対象シート
　If Err.Number <> 0 Then
　　MsgBox shName & "は見つかりません。", vbExclamation
　　Exit Sub
　End If
　If StrComp(sh2.Name, shName, 1) = 0 Then
　　 MsgBox "シート名が不正です", vbExclamation
　　 Exit Sub
　End If
　With sh2
　If .Range("B2", .Cells(Rows.Count, 2).End(xlUp)).Rows.Count < 3 Then
　　MsgBox "データとして不足しています。", vbExclamation　'※※※
　　Exit Sub
　End If
　End With
　On Error GoTo 0
''-------エラーチェックの終わり---------
　With sh1
　 Set DB = .Range("B2", .Cells(Rows.Count, 2).End(xlUp)).Resize(, w)
　 Set DbField = .Range("B2:M2")
　 'MsgBox DB.Address(, , , True) '確認用**
　End With
　
　With sh2
　　'一旦データを消す
　　.Range("B5", .Cells(Rows.Count, 2).End(xlUp)).Resize(, w).ClearContents
　　'クライテリアの設定
　　Set Crit = .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
　　'フィールド名のコピー※
　　DbField.Copy .Range("B5")　　'誤作動がなければ、なくても可***
　
　　'アドバンスフィルターの実行
　　DB.AdvancedFilter _
　　Action:=xlFilterCopy, _
　　CriteriaRange:=Crit, _
　　CopyToRange:=.Range("B5").Resize(, w), _
　　Unique:=False
　End With
End Sub
'///

添付画像は、他の質問の表を加工して、今回に合わせましたが、日付は、昨年の4月になっているのは、無視してください。

No.4 回答者： WindFaller 回答日時： 2015/05/03 05:58

こんにちは。

一応、最後のレスや書き込みから、１週間の猶予しかありませんので、放っておくと自動的に締められてしまいます。今回は、位置のズレに気が付かなくて、マクロが正しく働かなくなっただけだと思っておりますが、一度、見ていただけるとありがたいです。

この回答へのお礼

お礼が遅くなって申し訳ありません。
何度もご回答頂き本当にありがとうございました。

あれから色々試してみましたが、
おかげで上手く貼りつける事が出来ました！
ただ、アドバンスフィルターを使用すると、
どうしても元の書式まで貼りつけてしまうようなので（フォントサイズや色など)
貼りつけた後に書式設定をするマクロを追加することにしました。
本当にありがとうございました！

お礼日時：2015/05/04 13:15