こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

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

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

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

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

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

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

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

投稿日時 - 2006-02-01 21:27:11

QNo.1937200

困ってます

このQ&Aは役に立ちましたか?

2人が「このQ&Aが役に立った」と投票しています

回答(6)

ANo.6

Wendy02です。

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

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

Book_B = "B.xls"

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

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

投稿日時 - 2006-02-04 23:28:29

ANo.5

こんばんは。Wendy02です。

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

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

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

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

投稿日時 - 2006-02-04 19:42:06

お礼

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

投稿日時 - 2006-02-04 21:29:13

ANo.4

こんにちは。Wendy02です。

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

#取得セル範囲 A7:L300

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

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

ためしに以下のコードを試してみていただけますか?
このコードは、別の同一フォルダ上の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

投稿日時 - 2006-02-04 12:13:49

補足

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

投稿日時 - 2006-02-04 17:34:50

ANo.3

こんばんは。

#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 は、必ず明示的に指定します。

投稿日時 - 2006-02-01 23:54:19

補足

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

一覧のデータをオートフィルタで欲しいデータだけ
表示させます。
その後
コピー元
ワークブック A
   シート a
取得セル範囲 A7:L300

から

コピー先
ワークブック B
   シート a
コピー先(起点となる)セルA7

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

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

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

投稿日時 - 2006-02-03 22:29:13

ANo.2

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

新規ブックを2つ開いて、一方に下記マクロをコピペ
実行するとマクロを記述したブックの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

投稿日時 - 2006-02-01 22:42:31

お礼

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

投稿日時 - 2006-02-04 18:32:54

ANo.1

こんばんは。

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

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

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

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

投稿日時 - 2006-02-01 21:53:15

補足

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

投稿日時 - 2006-02-01 23:09:27

あなたにオススメの質問