エクセルで変化する行数に対応してコピーするマクロ

質問

エクセルワークブックAを検索して見つかった範囲をワークブックBのシートとセルを指定して転記するマクロ。

このようなマクロコードを教えてください。

ブックAのシート１に以下のような配置で文字と数値が入っています。

A列 　　　　　　　B列 　　　　　C列　　　　　 D列　　　　　 E列
あいう　えお　　
　　　　　　　　　10 　　　　　　aa 　　　　　かかか　　　　 123
　　　　　　　　　20　　　　　　 ss 　　　　　ききき 　　　　456
　　　　　　　　　　　　　　　　　　　　　　　くくく　　　　　 8910
　　　　　　　　　　　　　　　　　　　　　　　けけけ　　　　 234
　　　　　　　　　　　　　　　　　　　　　　　こここ　　　　 5678
　　　　　　　　　　　　　　　　　　　　　　　さささ　　　　 9123
-------------スペース--------------------------------
かきく　けこ　　
　　　　　　　　　　10 　　　　　aa 　　　　　かかか　　　　 123
　　　　　　　　　　20 　　　　　ss 　　　　　ききき　　　　　 456
　　　　　　　　　　30 　　　　　dd 　　　　　くくく 　　　　　8910
　　　　　　　　　　　　　　　　　　　　　　　けけけ　　　　　 234
　　　　　　　　　　　　　　　　　　　　　　　こここ　　　　　 5678
-------------スペース--------------------------------
さしす　せそ　　
　　　　　　　　　　10　　　　　 aa 　　　　　かかか　　　　　 123
　　　　　　　　　　20　　　　　 ss 　　　　　ききき 　　　　　456
　　　　　　　　　　　　　　　　　　　　　　　くくく　　　　　　 8910
　　　　　　　　　　　　　　　　　　　　　　　けけけ 　　　　　　234
-------------スペース--------------------------------

上記の様にスペースとスペースの間を１グループとしてコピーしたいのですが、行数が変化します。
また列によって入力されてる行数も違います。

ブックBから操作するマクロでブックAのシート１の”あいう”という文字列を含んだセルを検索して、
次のスペースまでの１グループをコピーしてブックBのシート１のA1に貼り付ける。
（あいう　えお～9123まで）

続いてブックAのシート１の”かきく”という文字列を含んだセルを検索して、
次のスペースまでの１グループをコピーしてブックBのシート２のA1に貼り付ける。
（かきく　けこ～5678まで）

ブックAのシート１の”さしす”という文字列を含んだセルを検索して、
次のスペースまでの１グループをコピーしてブックBのシート３のA1に貼り付ける。
（さしす　せそ～234まで）

*ブックAのファイル名は固定ですが、ブックBは毎回違います。
マクロの実行はブックBから行います。

この様な条件でのマクロを教えてください。

行数変化に対応している部分に但し書きを付けて頂けると応用が利きますので有難いです。

回答No.9

n-jun · ベストアンサー

ANo.8です。

>ブックＡのシート１のデータをブックＢのシート１～３に貼り付けたら、続いてブックＡのシート２のデータをブックＢのシート４～６に
>貼り付けて、ブックＡのシート３のデータをブックＢのシート７～９という風になれば理想的です。

Sub　Test4()
　Dim　wb　As　Workbook
　Dim　ws　As　Worksheet
　Dim　i　As　Integer
　Dim　ws_name,　F_name,　r　As　Range

　'データを書き込むブックのセット
　Set　wb　=　ThisWorkbook

　For　Each　ws_name　In　Array("Sheet1",　"Sheet2",　"Sheet3")

　　　　　'データのあるブック＆シートセット
　　　　　'ブック名・シート名は適宜修正のこと
　　　　　Set　ws　=　Workbooks("Book1.xls").Worksheets(ws_name)

　　　　　'検索したい文字をセットし順次与える
　　　　　For　Each　F_name　In　Array("あいう",　"かきく",　"さしす")

　　　　　　　　　With　ws　　'値の検索（部分一致）
　　　　　　　　　　　　　　Set　r　=　.Range("A:A").Find(what:=F_name,　After:=.Range("A"　&　Rows.Count),　_
　　　　　　　　　　　　　　　　　　　　　　LookIn:=xlValues,　LookAt:=xlPart,　SearchOrder:=xlByColumns).CurrentRegion
　　　　　　　　　End　With
　　　　　　　　　i　=　i　+　1
　　　　　　　　　r.Copy　wb.Worksheets(i).Range("A1")
　　　　　Next
　Next
　Set　r　=　Nothing
End　Sub
こうゆう事でしょうか？

お礼

凄い！完璧です。
わがままを聞いて下さり感謝いたします。
ありがとうございました。

回答No.8

n-jun

ANo.7です。

>検索する文字が完全一致ではなく、含んだ文字。
ここはANo.1さんが回答しているFindメソッドの”LookAt:=xlPart”です。
前回のと比べると違いがわかります。

>もう一つはコピーの範囲が決まってるのではなく、
>検索した文字列のセルを含んだ行から次のスペースの範囲まで。
ANo.1さんが回答してますFindメソッドの結果に対して行なっている、
”.CurrentRegion”です。

最低限必要としている部分は既に回答が出ていますよ。

取り敢えずブックＡ及びブックＢを開いた状態でブックＢに下記コード貼付。
Sub　Test3()
　　Dim　wb　As　Workbook
　　Dim　ws　As　Worksheet
　　Dim　i　As　Integer,　j　As　Integer
　　Dim　F_name,　r　As　Range

　　　　　　　　　　　　　　　　　　　　　　　　　'データのあるブック＆シートセット
　　　　　　　　　　　　　　　　　　　　　　　　　'ブック名・シート名は適宜修正のこと
　　Set　ws　=　Workbooks("Book1.xls").Worksheets("Sheet1")

　　　　　　　　　　　　　　　　　　　　　　　　　'データを書き込むブックのセット
　　Set　wb　=　ThisWorkbook
　　j　=　wb.Worksheets.Count

　　　　　　　　　　　　　　　　　　　　　　　　　　　'検索したい文字をセットし順次与える
　　For　Each　F_name　In　Array("あいう",　"かきく",　"さしす")

　　　　　　　　　　With　ws　　　　　　　　　　'値の検索（部分一致）
　　　　　　　　　　　　　　　　　　　　Set　r　=　.Range("A:A").Find(what:=F_name,　After:=.Range("A"　&　Rows.Count),　_
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　LookIn:=xlValues,　LookAt:=xlPart,　SearchOrder:=xlByColumns).CurrentRegion
　　　　　　　　　　End　With
　　　　　　　　　　i　=　i　+　1

　　　　　　　　　　With　wb　　　　　　　　　　'データを書き込むシートが足りない場合は追加する。
　　　　　　　　　　　　　　　　　　　　If　i　>　j　Then
　　　　　　　　　　　　　　　　　　　　　　　　　　.Worksheets.Add　After:=.Worksheets(.Worksheets.Count)
　　　　　　　　　　　　　　　　　　　　　　　　　　j　=　.Worksheets.Count
　　　　　　　　　　　　　　　　　　　　End　If
　　　　　　　　　　End　With

　　　　　　　　　　r.Copy　wb.Worksheets(i).Range("A1")

　　Next
　　Set　r　=　Nothing
End　Sub
でしょうか。

補足

ありがとうございます。
あと一歩ってところなんですけど・・・。
この部分Set　ws　=　Workbooks("Book1.xls").Worksheets("Sheet1")
は複数のシートを指定できないのでしょうか？
Set　ws　=　Workbooks("Book1.xls").Worksheets("Sheet1","Sheet2","Sheet3")と変更したらダメでした。

質問ではブックＡのシート１だけでお尋ねしたのでこのように回答いただいたのですが、私はあほでマクロのコードがよく分からないので、
１つの動作を教えて頂いてそれを単純に何回も繰り返そうと思っていました。
つまり「ブックＡのシート１を検索して見つかった１グループをブックＢのあるシートとセルを指定して貼り付けるだけの動作」を検索する文字列の数だけマクロで連続実行させようと思っていました。

親切に貼り付ける先のシートも順番に振り分けるようになっていたので、その部分も変更する（Ｂのシートを指定する方法）のが分からなくて困っていました。
なるべく複雑にならないようにお手数をかけまいと考えて質問すると、
さらに違う方向に行ってしまい自爆です。

もしブックＡの複数のシートを指定して実行できるならそれに越した事は無いのです。
ブックＡのシート１のデータをブックＢのシート１～３に貼り付けたら、続いてブックＡのシート２のデータをブックＢのシート４～６に貼り付けて、ブックＡのシート３のデータをブックＢのシート７～９という風になれば理想的です。
ブックＢのシートが足りなくなる事はありません。
これが複雑で大変でしたら、ブックＡからコピーしたデータを単純にブックＢの指定のシートのセルに貼り付ける方法が分かればお願いします。それを何回も繰り返しますので。
すいませんお願いします。

回答No.7

n-jun

ブックＡにコードを貼付して実行。
実行時に書き込みたいブックＢを指定して開く。

Sub　Test2()
　Dim　wb　As　Workbook
　Dim　ws　As　Worksheet
　Dim　i　As　Integer,　j　As　Integer
　Dim　r　As　Range
　Dim　F_name,　OP_name　As　String

　　　　　　　　　　　　　　　　　　　'データのあるブック＆シートセット
　Set　ws　=　ThisWorkbook.Worksheets("Sheet1")

　　　　　　　　　　　　　　　　　　　'書き込むブックを選択して開く
　OP_name　=　Application.GetOpenFilename("Microsoft　Excelブック,*.xls")
　If　OP_name　=　"False"　Then　Exit　Sub
　On　Error　Resume　Next
　Workbooks.Open　Filename:=OP_name
　If　Err　<>　0　Then　Exit　Sub

　　　　　　　　　　　　　　　　　　　'データを書き込むブックのセット
　Set　wb　=　ActiveWorkbook

　　　　　　　　　　　　　　　　　　　'検索したい文字をセットし順次与える
　For　Each　F_name　In　Array("あいう",　"かきく",　"さしす")

　　　　　With　ws　　　　　　　'値の検索
　　　　　　　　　　Set　r　=　.Range("A:A").Find(what:=F_name,　After:=.Range("A"　&　Rows.Count),　_
　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　LookIn:=xlValues,　LookAt:=xlPart).CurrentRegion
　　　　　End　With
　　　　　i　=　i　+　1

　　　　　With　wb　　　　　　　　　　　　　'データを書き込むシートが足りない場合は追加する。
　　　　　　　　　　If　i　>　j　Then
　　　　　　　　　　　　　.Worksheets.Add　After:=.Worksheets(.Worksheets.Count)
　　　　　　　　　　　　　j　=　.Worksheets.Count
　　　　　　　　　　End　If
　　　　　End　With

　　　　　r.Copy　wb.Worksheets(i).Range("A1")

　Next
　Set　r　=　Nothing
End　Sub
ではどうでしょうか？

補足

何度も回答頂きありがとうございます。
私の求めている内容とは違うようです。
以前にn-junさんに回答頂いた、
​http://oshiete1.goo.ne.jp/qa4269678.html​
この場合と今回との違いは、検索する文字が完全一致ではなく、
含んだ文字。
もう一つはコピーの範囲が決まってるのではなく、
検索した文字列のセルを含んだ行から次のスペースの範囲まで。
これを教えて頂けませんか？
どうしてもブックAからBへはダメなんです。
現在開いてるブックからAに検索に行く方法しか使えないのです。

回答No.6

n-jun

ANo.3です。
追加です。

＞ブックBは既にあるファイルで名前も決まっています。
＞別名で何百もあるファイルです。（ブックB１～ブックB2・・・・）
＞ブックAは１つだけのファイル。
＞ブックBからブックAに見に行き目的の名前の部分をコピーして持って帰ってくるというイメージです。
別段ブックＡから任意のブックＢを選択・開いて実行もできますが、
その際にも書き込みたいシートと、ブックＡの個々のデータ固まりのどれがつながるのかが不明ですけど。

補足

すいません、そうですね。
例えば”あいう”を検索した１グループはブックBのシート１のA１に貼り付けるというマクロが分かれば、２つ目からは同じマクロで検索文字を”かきく”として貼り付けるシートをブックBシート２A1という具合に代えれば良いと思ったのです。

回答No.5

n-jun

ANo.3です。

”あいう”・”かきく”という検索値は当然ダミーですよね。
では実際にはどこからその検索値を持ってくるのか、と言う事が問題になります。

ブックＢから引っ張るとした場合に、例えばシート名にある名前と一致したデータを持ってくるとか。
何かしらの検索値として与える条件がなければ、なが～いコードをひたすら書かなければなりませんよ。

提示したコードは単に上から順番に各々のシートに放り込むタイプで、検索値に依存しません。

補足

すいません、”あいう”はダミーじゃないです。
毎回その文字なんです。
宜しくお願いします。

回答No.4

n-jun

ANo.3です。
ちょっと訂正です。
Do～Loop間を以下に変更願います。

　　Do　
　　　　　　　　　　If　i　=　j　Then
　　　　　　　　　　　　　　　　wb.Worksheets.Add　After:=wb.Worksheets(wb.Worksheets.Count)
　　　　　　　　　　　　　　　　j　=　wb.Worksheets.Count
　　　　　　　　　　End　If
　　　　　　　　　　i　=　i　+　1
　　　　　　　　　　r.CurrentRegion.Copy　wb.Worksheets(i).Range("A1")
　　　　　　　　　　If　r.Row　=　last_row　Then　Exit　Do
　　　　　　　　　　Set　r　=　r.End(xlDown)
　　Loop

補足

何度もすいません。
以前にn-junさんに回答頂いた、
http://oshiete1.goo.ne.jp/qa4269678.html
この場合と今回との違いは、検索する文字が完全一致ではなく、
含んだ文字。
もう一つはコピーの範囲が決まってるのではなく、
検索した文字列のセルを含んだ行から次のスペースの範囲まで。
それでご理解頂けるでしょうか？

回答No.3

n-jun

ANo.2です。

>ブックBは毎回違います。
仮にブックＢを実行の都度新規で作って良ければ、コードをブックＡに
貼り付けて実行してみて下さい。

Sub　test()
　Dim　wb　As　Workbook
　Dim　i　As　Integer,　j　As　Integer
　Dim　last_row　As　Long
　Dim　r　As　Range

　With　ThisWorkbook.ActiveSheet
　　　　　　Set　r　=　.Range("A1")
　　　　　　last_row　=　.Range("A"　&　Rows.Count).End(xlUp).Row
　End　With

　Workbooks.Add
　Set　wb　=　ActiveWorkbook
　j　=　wb.Worksheets.Count

　Do
　　　　　If　i　=　j　Then
　　　　　　　　wb.Worksheets.Add　After:=wb.Worksheets(wb.Worksheets.Count)
　　　　　　　　j　=　wb.Worksheets.Count
　　　　　End　If
　　　　　i　=　i　+　1
　　　　　r.CurrentRegion.Copy　wb.Worksheets(i).Range("A1")
　　　　　Set　r　=　r.End(xlDown)
　Loop　Until　r.Row　=　last_row
End　Sub
ブックＢの”名前を付けて保存”は手作業になりますが。。。
ご参考まで。

補足

回答ありがとうございます。
私の質問が悪いですね、うまく表現できなくて・・・。
ブックBは既にあるファイルで名前も決まっています。
別名で何百もあるファイルです。（ブックB１～ブックB2・・・・）
ブックAは１つだけのファイル。
ブックBからブックAに見に行き目的の名前の部分をコピーして持って帰ってくるというイメージです。
ご提示頂いたマクロの中には検索する文字が見当たりません。（１例目”あいう”）
今回の例だと”あいう”を含む文字のあるセルを検索して、
そのグループのスペース～スペースの間のをコピーしてブックBのシート１に貼り付けます。
次に別の文字”かきく”を含む文字のあるセルを検索して、
同じくそのグループをブックBのシート２に貼り付けます。

ブックBは基本となる基のファイルがあり、
それにいろんなデータを入れてから名前を付けて保存しています。
基本となる基のファイルにマクロを入れておきたいのです。
そうすれば名前が変わった後でも実行できると思ったのですが、違いますか？

私の望んでる事が分かり難いでしょうか？
ダメならただ単に
”あいう”を含む文字のあるセルを検索して、
そのグループのスペース～スペースの間のをコピーしてブックBのシート１に貼り付けます。
この部分だけのマクロをブックBから実行できれば良いのですけど、
宜しくお願いします。

回答No.2

n-jun

>*ブックAのファイル名は固定ですが、ブックBは毎回違います。
>マクロの実行はブックBから行います。
全てのブックBにコードを書くのですか？
変更があった場合、面倒に思うのですが・・・。

試しにブックＡに下記コードを貼り付けて実行してみると、範囲が取れてるのが
わかるかと思います。
Sub try()
MsgBox Range("A1").CurrentRegion.Address
MsgBox Range("A1").End(xlDown).CurrentRegion.Address
End Sub

回答No.1

masa_019

こんにちは。

Cells.Find(What:="あいう", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, MatchByte:=False, SearchFormat:=False).CurrentRegion.Copy

で"あいう"を含む1グループをコピーできますので、
後は好きなところに貼り付けれるだけです。

補足

回答ありがとうございます。
実行しましたが、エラーになってしまいます。
「実行時エラー”９１”
オブジェクト変数または１withブロック変数が設定されていません」と、表示が出ます。
どうすれば良いのでしょう？