Book間のデータ転記を自動化したい

質問

Book A からBook Bへ毎日データをコピーしています、これを自動化できないでしょうか？

Book A
　　　　 A　　　　B　　　　C　　　　D
1 会社名１　 data11 data12 data13
2 会社名２　 data21 data22 data23
3 会社名３　 data31 data32 data33

Book B
　　　　A　　　　B　　　　C　　　　D
1 日付１ 　data11 data12 data13
2 日付２ 　data14 data15 data16
3 日付３ 　data17 data18 data19

Book A は１日につき１ファイルづつ毎日増えていきます会社数は日によって違いますが大体40～50くらですデータ数は１行につき15個で一定です。
Book B は会社ごとにシートが作ってありBook Bの中に約35シート入っています。
少し説明がわかりにくいかもしれませんが、やりたいことは毎日Book Aというファイルを渡されるのでその中から主な会社35社のデータを会社別に日付順にしたいのでBook Bへ手作業でコピーしています、毎日のことなので結構大変です自動でコピーできないでしょうか？
それとも何か別の方法でもっとスマートに処理できますか？

回答No.6

papayuka

#1です。

ちなみに日付は実行日を入れるだけです。
複数回実行すると同じデータが追記されます。

後は環境に合わせて修正して下さい。

回答No.5

papayuka

#1です。

> BookBの中に無いシート名があるとそれ以下の行のデータは
> コピーされないようです。

そんな事は無いと思いますが。
そちらの環境が解りませんが、こちらは Excel2000 なのでバージョンの違いなのかなぁ、、、
テスト用のデータで試しているので行数は数十程度ですが、少なくともこちらでは会社名のシートが無くても止まりません。

補足

どうも有難うございました、データのコピーは正常に出来ました、
BookAの会社名の後に半角スペースが入っている物があったようでそれに気づかず会社名だけをコピーしてました、申し訳ありません。

回答No.4

papayuka

#1です。

If ws Is Nothing Then Exit Sub
の行を削除して実行すると「実行時エラー'91':オブジェクト変数またはWithブロック変数が設定されていません。」が出ますか？
前の時もそうですが、対象ブックが拾えないようで、こちらの想定出来る環境では無いのかも知れません。

新規ブックを作成し標準モジュールに#3のマクロをコピペ、同じウィンドウ内にもう一つ新規ブックを作成して、Sheet1のA1～C3に下記のようなデータを作って実行。
これでもダメならお手上げです。

Sheet1　　data1　　data1
Sheet2　　data2　　data2
Sheet3　　data3　　data3

お礼

マクロを改良していただきどうも有り難うございました、いろいろ試して見ましたほぼうまくいくんですが、BookAのＡ列会社名が全てBookBの中にあるシート名と一致していれば正常にコピーされますがBookBの中に無いシート名があるとそれ以下の行のデータはコピーされないようです。

補足

新規ブックを２つ作成してやってみたらうまくいきました、新規ブックにいままでのデータをコピーしてうまくいくか試してみます。

回答No.3

papayuka

#1です。

> デバッグボタンを押すとSet ws =　の行か゛黄色くなってます

ならば、ブック名またはシート名の指定が間違っているのでしょう。
拡張子を表示する設定にしてあるのに拡張子を書いていないとか、半角と全角が違うとか、ファイル名やシート名のあいだや後ろに空白文字があるなど、何処かに間違いがあると思われます。

　# hogehoge.xls なのに Workbooks("hogehoge") としている
　# Sheet１ なのに Worksheets("Sheet1") としている
　# シート１□（□は空白文字）なのに、Worksheets("シート１") としている、、、、など。

---------------

まあ、BookA は毎日増えるって事でファイル名に依存しない作りの方が良いですね。
ちょっと書換えて見ました。
条件は下記の通り。

1）BookBにマクロ記述、BookBの各シート名が、対象ブックの一番左のシートのA列にある会社名とマッチしている。
2）BookBと対象ブックの２つだけが開いている。
3）対象ブックの一番左のシートにデータがある。

Sub Test1()
Dim ws As Worksheet, wb As WorkBook

　For Each wb In Workbooks
　　If Windows(wb.Name).Visible Then
　　　If Not wb Is ThisWorkbook Then
　　　　 Set ws = wb.Worksheets(1)
　　　　 Exit For
　　　End If
　　End If
　Next wb

　If ws Is Nothing Then Exit Sub

　For Each r In ws.Range(ws.Range("A1"), ws.Range("A65536").End(xlUp))
　　　On Error Resume Next
　　　With ThisWorkbook.Worksheets(r.Value)
　　　　　r.EntireRow.Copy .Range("A65536").End(xlUp).Offset(1, 0)
　　　　 .Range("A65536").End(xlUp).Value = Date
　　　End With
　Next r
End Sub

補足

改良版のマクロをコピーして実行してみたのですが何も起こりませんでした、条件３つは大丈夫だと思うんですが、このままコピーするだけではだめなんでしょうか？
Bookは２つしか開いていません、マクロはBookBにコピーしました、会社名が違うといけないのでもう一度コピーしてシート名に貼り付けました、BookAにはシートは１つしかありません。

回答No.2

papayuka

#1です。

> 実行時エラー'9':インデックスが有効範囲にありません。
> こんなエラーメッセージがでます。

マクロは BookB に記載して、BookA と BookB を同時に開いて実行してますか？

これから旅行に出かけるので明日の夜まで返事は出来ませんが、、、

補足

BookA,BookBを同時に開いて実行してますがやはりエラーになります、デバッグボタンを押すとSet ws =　の行か゛黄色くなってます

回答No.1

papayuka

マクロ（VBA）ですね。

BookA のA列にある会社名と BookB のシート名が同じだとして、BookB 側にマクロを仕込んでおきます。
BookA と BookB を同時に開いて実行します。日付は実行した日

試すならテスト環境で。

Sub Test()
Dim ws As Worksheet
　　　　　'ブック名とシート名は環境に合わせて変更が必要
　Set ws = Workbooks("BookA.xls").Worksheets("Sheet1")
　For Each r In ws.Range(ws.Range("A1"), ws.Range("A65536").End(xlUp))
　　　On Error Resume Next
　　　With ThisWorkbook.Worksheets(r.Value)
　　　　　r.EntireRow.Copy .Range("A65536").End(xlUp).Offset(1, 0)
　　　　 .Range("A65536").End(xlUp).Value = Date
　　　End With
　Next r
End Sub

補足

回答ありがとうございます、マクロのことはほとんど解らないのですがとりあえずこの式をコピーして"BookA.xls" "Seet1"の所を実際のファイル名とシート名に変えて実行してみたのですが、実行時エラー'9':インデックスが有効範囲にありません。こんなエラーメッセージがでます。