エクセル マクロで別のブックに貼り付けたい！

質問

作成したシートを別のブック（既存）にマクロを使って貼り付けたい
のですが、いろいろ調べた結果以下のようにはすることができました。
----------------------------------------------------------------
Sub SaveSheet()
Dim sFileName As String

'ファイル名の設定
sFileName = "C:\a\test.xls"

'シートをコピーして新規ブックを作成
Sheets(Array("Sheet1", "Sheet2")).Copy

'作成したブックの保存
ActiveWorkbook.SaveAs sFileName
End Sub
----------------------------------------------------------------
これはとあるサイトで見つけたもので、私自身が作成したものでは
ありません。

このマクロの問題は、
○あらたにブック（シート）が作成されること
（マクロ実行時は上書きになるので、変更できなくても使えないわけ
ではない）
○元データはシート丸ごとであり、セル範囲を選択できない。
○貼り付けるシートにおいても、任意の場所を起点とできない。
ということです。

整理しますと、『作成したシートの任意のセル範囲を、別に存在する
ブックに、任意のセルを起点として貼り付けたい』
ということです。
どうかよろしくお願いします。m(_ _)m

回答No.6

Wendy02

Wendy02です。

この設定部分、チェックのために変更しただけなので、

＞ Book_B = "C:\MY Documents\B.xls"

Book_B = "B.xls"

元に戻しておいてください。

急いでいたので、そのままになってしまいました。
スミマセン。

回答No.5

Wendy02

こんばんは。Wendy02です。

＞オートフィルタのプルダウンメニューなどを含む領域が選ばれてしまい、結局すべてのデータ（ある意味シート丸ごと）がコピーされてしまったのであきらめていました。

気が付かなくてすみません。

＞currentregionでなんとかなるとは思ったんですけどね・・・

CurrentRegion で範囲を取る場合は、Offset で一行下げて(-1)、Resizeで、CurrentRegion の行数(Rows.Count)から－１を引くと、タイトル行がない部分の範囲が取れます。コードの中に、二種類の方法が書いてありますので、研究してみてください。今回は、AutoFilterのRangeを使っています。

それから、バグを見つけましたので、最初から書き直しました。定数で設定するのはやめることにしました。他のフォルダにある場合、既に開いていた場合に、設定できないことが分りました。なお、ご自分でマクロをお作りになる場合は、二つのブックを開いておけば、単に、Set Bk1 = Workbooks(Book_A) : Set Bk2 = Workbooks(Book_B) だけで、その前の部分は、まったく必要ありません。

'--------------------------------------------------
Sub CopySelectedRangeR()
'オートフィルタの領域をコピーする
　 Dim BK1 As Workbook
　 Dim BK2 As Workbook
　 Dim dummy As Variant
　 Dim Book_A As String
　 Dim Book_Ar As String
　 Dim Sheet_A As String
　 Dim Cell_A As String
　 Dim Cell_A_Last As String
　 Dim Book_B As String
　 Dim Book_Br As String
　 Dim Sheet_B As String
　 Dim Cell_B As String

'設定項目
　 Book_A = "A.xls"
　 Sheet_A = "a"
　 Cell_A = "A7"
　 Cell_A_Last = "L300" 'CELL_Aの終点
　 Book_B = "C:\MY Documents\B.xls"
　 Sheet_B = "a"
　 Cell_B = "A7"

'ブックの存在の確認
　 If Dir(Book_A) = "" Then _
　 MsgBox Book_A & "　は、同じフォルダにないか、ブックが見当たりません。", vbInformation: Exit Sub
　 If Dir(Book_B) = "" Then _
　 MsgBox Book_B & "　は、同じフォルダにないか、ブックが見当たりません。", vbInformation: Exit Sub

　 On Error GoTo Quit
'ブック名を取る
　 If InStr(Book_A, "\") > 0 Then
　　　Book_Ar = Mid$(Book_A, InStrRev(Book_A, "\") + 1)
　 Else
　　　Book_Ar = Book_A
　 End If
　 If InStr(Book_B, "\") > 0 Then
　　　Book_Br = Mid$(Book_B, InStrRev(Book_B, "\") + 1)
　 Else
　　　Book_Br = Book_B
　 End If

　 dummy = Evaluate("[" & Book_Ar & "]" & Sheet_A & "!" & Cell_A)
　 If IsError(dummy) Then
　　　Set BK1 = Workbooks.Open(Book_A)
　 Else
　　　Set BK1 = Workbooks(Book_Ar)
　 End If

　 dummy = Evaluate("[" & Book_Br & "]" & Sheet_B & "!" & Cell_B)
　 If IsError(dummy) Then
　　　Set BK2 = Workbooks.Open(Book_B)
　 Else
　　　Set BK2 = Workbooks(Book_Br)
　 End If

　'実行準備
　 If BK1.Worksheets(Sheet_A).AutoFilterMode = False Then
　　　Application.Goto BK1.Worksheets(Sheet_A).Range(Cell_A)
　　　MsgBox "オートフィルターモードになっておりません。": GoTo Quit
　Else
　　　If BK1.Worksheets(Sheet_A).FilterMode = False Then
　　　 Application.Goto BK1.Worksheets(Sheet_A).Range(Cell_A)
　　　If MsgBox("オートフィルタが選択モードになっておりませんが、続行しますか？", vbOKCancel) = vbCancel Then GoTo Quit
　　　End If
　 End If

　 If WorksheetFunction.CountA(BK2.Worksheets(Sheet_B).Range(Cell_B).CurrentRegion) > 0 Then
　　　Application.Goto BK2.Worksheets(Sheet_B).Range(Cell_B)
　　　If MsgBox("データがあるようです。データを削除してよろしいですか？", vbOKCancel) = vbOK Then
　　　　 BK2.Worksheets(Sheet_B).Range(Cell_B).CurrentRegion.ClearContents
　　　　 Else
　　　　 GoTo Quit
　　　End If
　 End If

'領域をコピー

　　　With BK1.Worksheets(Sheet_A).AutoFilter.Range
　　　　 .Offset(1).Resize(.Rows.Count - 1).Copy _
　　　　　BK2.Worksheets(Sheet_B).Range(Cell_B)
　　　End With

'' 以下の方が一般的です。
'　　　With BK1.Worksheets(SHEET_A).Range(CELL_A).CurrentRegion
'　　　　.Offset(1).Resize(.Rows.Count - 1).Copy _
'　　　　 BK2.Worksheets(SHEET_B).Range(CELL_B)
'　　　End With

　　　Application.Goto BK2.Worksheets(Sheet_B).Range(Cell_B)
　　　MsgBox "コピー完了しました。" & vbCrLf & "保存は、手動で行ってください。" & vbCrLf & "終了!"
Quit:
　　　If Err.Number > 0 Then
　　　　 MsgBox Err.Number & ": " & Err.Description
　　　End If
　　　Set BK1 = Nothing: Set BK2 = Nothing
End Sub
'--------------------------------------------------

お礼

何度も何度もありがとうございました。
本当に親切にして頂いて感激です。
設計して頂いたコードを使わせて頂きます。
m(_ _)m

回答No.4

Wendy02

こんにちは。Wendy02です。

返事が遅くなってすみません。

#取得セル範囲　Ａ７：Ｌ３００

# セル範囲を取得する際、明示的に指示するのではなく、データの入っているセル範囲を取得できれば言うこと無しです。

通常、オートフィルタの場合は、選択モードになっていれば、それをそのまま、範囲を取得すれば、いらないデータは含まれずにコピー&ペーストできるはずなのです。

ためしに以下のコードを試してみていただけますか？
このコードは、別の同一フォルダ上のA,B以外のブックでも、コピーする側でも、ペーストされる側でも、「標準モジュール」にありさえすれば、問題なくコピーされると思います。同一フォルダーにない場合は、ファイル名にドライブ\フォルダから、フルネームで書いてください。また、最初に、開けていない場合は、自動的にブックを開けるように作られています。

Sub CopySelectedRange()
'オートフィルタの領域をコピーする
　 Dim BK1 As Workbook
　 Dim BK2 As Workbook
　 Dim dummy As Variant

'設定項目
　 Const BOOK_A As String = "A.xls"　'ブック名
　 Const SHEET_A As String = "a"　'シート名
　 Const CELL_A As String = "A7"　'基点のセル番地
　 Const CELL_A_LAST As String = "L300" 'CELL_Aの終点
　 Const BOOK_B As String = "B.xls"
　 Const SHEET_B As String = "a"
　 Const CELL_B As String = "A7"

'ブックの存在の確認
　 If Dir(BOOK_A) = "" Then _
　 MsgBox BOOK_A & "　は、同じフォルダにないか、ブックが見当たりません。", vbInformation: Exit Sub
　 If Dir(BOOK_B) = "" Then _
　 MsgBox BOOK_B & "　は、同じフォルダにないか、ブックが見当たりません。", vbInformation: Exit Sub

　 On Error GoTo Quit
　 dummy = Evaluate("[" & BOOK_A & "]" & SHEET_A & "!" & CELL_A)
　 If IsError(dummy) Then
　　　Set BK1 = Workbooks.Open(BOOK_A)
　 Else
　　　Set BK1 = Workbooks(BOOK_A)
　 End If

　 dummy = Evaluate("[" & BOOK_B & "]" & SHEET_B & "!" & CELL_B)
　 If IsError(dummy) Then
　　　Set BK2 = Workbooks.Open(BOOK_B)
　 Else
　　　Set BK2 = Workbooks(BOOK_B)
　 End If

　'実行準備
　 If BK1.Worksheets(SHEET_A).AutoFilterMode = False Then
　　　Application.Goto BK1.Worksheets(SHEET_A).Range(CELL_A)
　　　MsgBox "オートフィルターモードになっておりません。": GoTo Quit
　Else
　　　If BK1.Worksheets(SHEET_A).FilterMode = False Then
　　　 Application.Goto BK1.Worksheets(SHEET_A).Range(CELL_A)
　　　If MsgBox("オートフィルタが選択モードになっておりませんが、続行しますか？", vbOKCancel) = vbCancel Then GoTo Quit
　　　End If
　 End If

　 If WorksheetFunction.CountA(BK2.Worksheets(SHEET_B).Range(CELL_B).CurrentRegion) > 0 Then
　　　Application.Goto BK2.Worksheets(SHEET_B).Range(CELL_B)
　　　If MsgBox("データがあるようです。データを削除してよろしいですか？", vbOKCancel) = vbOK Then
　　　　 BK2.Worksheets(SHEET_B).Range(CELL_B).CurrentRegion.ClearContents
　　　　 Else
　　　　 GoTo Quit
　　　End If
　 End If

'領域をコピー
　　　BK1.Worksheets(SHEET_A).Range(CELL_A & ":" & CELL_A_LAST).Copy _
　　　BK2.Worksheets(SHEET_B).Range(CELL_B)

　　　Application.Goto BK2.Worksheets(SHEET_B).Range(CELL_B)
　　　MsgBox "コピー完了しました。" & vbCrLf & "保存は、手動で行ってください。" & vbCrLf & "終了!"
Quit:
　　　If Err.Number > 0 Then
　　　　 MsgBox Err.Number & ": " & Err.Description
　　　End If
　　　Set BK1 = Nothing: Set BK2 = Nothing
End Sub

補足

ありがとうございます。
うまくコピーができました。感激です。
もう一つよろしいでしょうか？
前回コピーする範囲について書かせて頂いたのですが、
一覧から取得するので、その一覧そのもの列は日々増えていきます。
ですので、オートフィルタで選択モードにした際に
データの入っている範囲を自動で取得できればな
と思った次第です。
私自身も以前ない知恵をしぼって一度試してみたのですが、
オートフィルタのプルダウンメニューなどを含む領域が
選ばれてしまい、結局すべてのデータ（ある意味シート丸ごと）
がコピーされてしまったのであきらめていました。
currentregionでなんとかなるとは思ったんですけどね・・・
お時間があればよろしくお願いします。m(_ _)m

回答No.3

Wendy02

こんばんは。

#1のWendy02です。

その回答の補足の内容って、最近、私が作ったばかりの話に良く似ています。一応、私の作ったものも、参考にしていただけますか？ただ、コードだけみても、分りにくいかもしれません。もう少し、詳しい情報として、サンプル用データと、全体の構成が分れば、新たに考えてみます。私の場合、必ず、エラーオプション処理をしますので、コードが長くなってしまいますので。

http://oshiete1.goo.ne.jp/kotaeru.php3?q=1918979
(http://security.okwave.jp/kotaeru.php3?q=1918979)

ExcelVBAを使っての振り分け処理

つまり、これは、最初に、「初めに振り分け用のシートありき」、「初めに条件ありき」というコードの構造になっているわけなのです。

たぶん、オートフィルタの Range("A1").CurrentRegion だけで、範囲は取れるはずです。非表示データは、コピーされませんので、そのまま貼り付けが聞きます。

つまり、

例えば、サブルーチンで、

rng　というのは、 Range("A1").CurrentRegion　のことで、これと、shName（シート名）を引数にして、貼り付けてしまいます。

With rng
　 .Offset(1).Resize(.Rows.Count - 1).Copy _
　　wb.Worksheets(shName).Range("A65536").End(xlUp).Offset(1)
End With

とすればよいわけですね。ただし、私の設計の仕方は、wb は、必ず明示的に指定します。

補足

何度もありがとうございます。
せっかくコードを載せて頂いたのですが私にはちょっと・・・
サンプルというか、具体的にしたいことを書きますので
お時間があれば設計をよろしくお願いします。

一覧のデータをオートフィルタで欲しいデータだけ
表示させます。
その後
コピー元
ワークブック　Ａ
　　　シート　ａ
取得セル範囲　Ａ７：Ｌ３００

から

コピー先
ワークブック　Ｂ
　　　シート　ａ
コピー先（起点となる）セルＡ７

にデータをコピーします。
以上です。

セル範囲を取得する際、明示的に指示するのではなく、
データの入っているセル範囲を取得できれば言うこと無しです。

好き勝手書きましたが、何卒お願いします。

回答No.2

papayuka

意味が違うかも知れませんが、、、
参考程度にはなるでしょうか。

新規ブックを２つ開いて、一方に下記マクロをコピペ
実行するとマクロを記述したブックのSheet1!A1:A10 をもう一方のブックのSheet1のA列にコピーします。
（実行するたびに下に追加コピー）

Sub Test()
Dim wb As Workbook, r As Range
Set r = ThisWorkbook.Worksheets(1).Range("A1:B10")
For Each wb In Workbooks
　If Not wb Is ThisWorkbook And _
　　 Windows(wb.Name).Visible Then
　　 r.Copy Destination:= _
　　　　wb.Worksheets(1).Range("A65536").End(xlUp).Offset(1, 0)
　　 Exit For
　End If
Next wb
End Sub

お礼

コピーが出来ました！！！
ありがとうございます。
ブック名やシート名、セル範囲は変更可能ですよね。

回答No.1

Wendy02

こんばんは。

＞『作成したシートの任意のセル範囲を、別に存在するブックに、任意のセルを起点として貼り付けたい』

それは、マクロを対話型にするという意味なのでしょうか？
実務上では、対話型にしたら、逆に使いづらいような気がします。

ふたつのブックを開けておいて、コピー＆ペーストでよいと思うのですが、それじゃいけないのでしょうか？そのために、マクロを必要とするとは思えないのですが。

「シートの任意のセル範囲を→他のブックの任意のシートの任意のセル」
に出てくる「任意」は、任意というよりも、その場所自体を、マクロで決めていくような設定をしなければ、マクロとしての意味がありませんね。それは、元の質問に出ていたようなマクロとは、考え方自体が違いますね。

補足

早速解答ありがとうございます。
私の説明がわるかったみたいですね。
おっしゃるとおり、ふたつのブックを開けておいて、コピー＆ペースト
で全然問題ありません。一つや二つなら・・・
実は、この操作には流れがありまして、一覧をフィルタで条件別に
表示→その結果を別のブックに貼り付け　というこで
その『条件別』が結構あります。
そこで、マクロを利用して一度でこの動作を実現させようとしている
のです。
ちなみに、任意とは、対話型で指定するわけではなく常に一定です。
シートを丸ごとコピーするのではなく、指定した、つまり任意の場所を
こちらで指定しておいてマクロを実行させたいのです。
調べていく中で、rangeというものを使うとセル範囲等を指定できる
らしいのですが、いかんせんスキルがないものですからご教授願えたら
と思いまして・・・
よろしくお願いします。