ＡファイルからＢファイルへ１回でコピーする方法

質問

exce2010

ＡのファイルからＢのファイルへコピーをします。
Ａのファイルのsheet1　C2からN2までのセルをBファイルで、
Xという名前をC列で参照して、当てはまるセルへコピーします
また、
O2からR2までのセルをBファイルで、
Yいう名前をC列で参照して、当てはまるセルへコピーします
下記のマクロでことたりているのですが、
Ａのファイルのシートは１行にデータが登録されているのに対し、
Ｂのファイルは、シート２行にデータが登録されています。

下記イメージです
Ａファイル
Ａ　Ｂ　Ｃ　Ｄ　Ｅ　Ｆ　Ｇ　Ｈ　Ｉ　Ｊ　Ｋ　Ｌ　Ｍ　Ｎ　Ｏ　Ｐ　Ｑ　Ｒ
　　　　あ　い　う　え　お　か　き　く　け　こ　さ　し　す　せ　そ　た

Ｂファイルのコピー前（Ｃ列のどこかにＸ、Ｙが登録されている）
Ａ　Ｂ　Ｃ　Ｄ　Ｅ　Ｆ　Ｇ　Ｈ　Ｉ　Ｊ　Ｋ　Ｌ　Ｍ　Ｎ
　　　　Ｙ
　　　　Ｘ　
ＸとＹの行位置は変わる可能性あるのでＣ列を参照してコピーする

コピー後
Ｂファイル
Ａ　Ｂ　Ｃ　Ｄ　Ｅ　Ｆ　Ｇ　Ｈ　Ｉ　Ｊ　Ｋ　Ｌ　Ｍ　Ｎ　Ｏ
　　　　Ｙ　す　せ　そ　た
　　　　Ｘ　あ　い　う　え　お　か　き　く　け　こ　さ　し　

という配置になるのです。
Ａファイルの所定セルをコピー、Ｂのファイルを開いてセーブして閉じる
再度
Ａファイルの所定セルをコピー、Ｂのファイルを開いてセーブして閉じる
としてるのですが、これを、Ｂのファイルを２回開くのではなく、
1回だけ開いて所定の配置にコピーできないでしょうか？

下記がマクロ抜粋です（kはシート名称になります。セルの値で、日付を指定しています）
'コピー先のシートを開く

Workbooks("A.xlsm").Worksheets("Sheet1").Activate
Calculate
Range(Cells(2, 3), Cells(2, 14)).Copy
'
'集計用のファイルを開く
Workbooks.Open "\\B.xls"

'シート指定
Worksheets(k).Activate

'コピー貼り付け。Ｘの配置行が変更されても大丈夫な対応

Range("C1:C200").Find("X").Select

Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

On Error Resume Next
ActiveWorkbook.Save
If Err.Number > 0 Then MsgBox "保存されませんでした"

ActiveWorkbook.Close

'コピー先のシートを開く

Workbooks("A.xlsm").Worksheets("Sheet1").Activate
Range(Cells(2, 15), Cells(2, 18)).Copy

'集計用のファイルを開く
Workbooks.Open "\\B.xls"

'シート指定
Worksheets(k).Activate
'コピー貼り付け。Yの配置行が変更されても大丈夫な対応
Range("C1:C200").Find("Y").Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
On Error Resume Next
ActiveWorkbook.Save
If Err.Number > 0 Then MsgBox "保存されませんでした"
ActiveWorkbook.Close

回答No.1

tsubu-yuki · ベストアンサー

両方のシートを変数に収めてしまうと良いかもです。
極力、ご提示の内容を使って、

Dim AWB As Workbook, ASH As Worksheet
Dim BWB As Workbook, BSH As Worksheet

　　　　Set AWB = Workbooks.Open("A.xlsm")
　　　　　　　　Set ASH = AWB.Worksheets("Sheet1")
　　　　Set BWB = Workbooks.Open("B.xls")
　　　　　　　　Set ASH = AWB.Worksheets(k)

　　　　ASH.Range(ASH.Cells(2, 3), ASH.Cells(2, 14)).Copy
　　　　BSH.Range("C1:C200").Find("X").PasteSpecial Paste:=xlPasteAllExceptBorders, _
　　　　　　　　　　　　　　　　　　　　　　　　Operation:=xlNone, _
　　　　　　　　　　　　　　　　　　　　　　　　SkipBlanks:=False, _
　　　　　　　　　　　　　　　　　　　　　　　　Transpose:=False
　　　　ASH.Range(ASH.Cells(2, 15), ASH.Cells(2, 18)).Copy
　　　　BSH.Range("C1:C200").Find("Y").PasteSpecial Paste:=xlPasteAllExceptBorders, _
　　　　　　　　　　　　　　　　　　　　　　　　Operation:=xlNone, _
　　　　　　　　　　　　　　　　　　　　　　　　SkipBlanks:=False, _
　　　　　　　　　　　　　　　　　　　　　　　　Transpose:=False
　　　　On Error Resume Next
　　　　BWB.Save
　　　　If Err.Number > 0 Then MsgBox "保存されませんでした"
　　　　BWB.Close

こんな感じでしょうか。
すいませんが、未検証です。

お礼

ありがとうございます。

補足

条件として記載していませんでしたが、Aのファイルはオートオープンで開いているので、上記マクロを実行すると、おかしな状況に陥りました。
　　　　Set AWB = Workbooks.Open("A.xlsm")
　　　　　　　　Set ASH = AWB.Worksheets("Sheet1")
の部分で２回同じファイルを読む設定になってしまう為です。
Aのファイルを異なるファイルにし、
　Set BWB = Workbooks.Open("B.xls")
　　　　　　　　Set ASH = AWB.Worksheets(k)
は
　Set BWB = Workbooks.Open("B.xls")
　　　　　　　　Set BSH = BWB.Worksheets(k)
とすることで対応出来ました。

回答No.2

imogasi

質問がよくわからんが
Ａ１：Ｇ１の各セルに
a bb c d eee f g
と、入っていて
Sub test01()
Dim x, y As Variant
x = Range("A1:C1")
y = Range("D1:g1")
Range("a3:C3") = x
Range("a7:d7") = y
End Sub
を実行して
結果
Ａ３：Ｃ３
a bb c
Ａ７：Ｄ７
d eee f g
のようになる。
１セルづつ代入文を書いてなくて、２行で済む。
こういう「コード経済・節約」をしたいのか？見通しも良くなる。
シート間に跨いでもこれができると思うが。

お礼

回答ありがとうございます。
参考にさせていただきました。