Excel2007 VBAでブックのコピーについて

質問

VBAでブックのコピー仕方が分からないので教えて下さい

やりたいことはBook1とBook2のシートデータを統合した物をBook3に書き出したいです

具体的には以下になります

Ｂｏｏｋ１

シート名

パターン1　パターン5　A-1　B-2　B-3　B-4　C-1　C-3　C-5　C-7

Book2

パターン2　パターン3　パターン4　パターン6　D-5　D-6　D-7　D-8　E-9　E-10　Ｆ－１　F-5

これをパターン1を先頭にアルファベット順に整列してBook3に書き出す作業をしたいです

求めている結果

Book3

パターン1 パターン2 パターン3　パターン4　パターン5 A-1　B-2　B-3　B-4　C-1　C-3　C-5　C-7 D-5　D-6　D-7　D-8　E-9　E-10　Ｆ－１　F-5

Book1とBook2のシート名に関しては重複するシート名はないが並び順がばらばらなので

Book3に合体させたときにパターン1を先頭にアルファベットのA-1から順番に整列させたいです

どのようにマクロを記述したらいいのか分からず困っているのでよろしくお願いします

シートの中には画像やオートシェイプなども入っています

回答No.5

tom04 · ベストアンサー

No.2・3です。

投稿後に思ったのですが・・・
補足の2番目
＞また、ID名に132と76などの数字が入っていると132の方が前にきてしまいます

は「ID名」とはSheet名のコトでその並びが希望通りにならない！ということでしょうか？
もしそうであれば、
前回のコードはとりあえずSheet名を新しいSheetに列挙し、並び替えを行っていますので、
数値の後に文字列があればそうなります。

その回避方法としては数値の桁数を揃えるといった工夫が必要になると思います。
132〇〇〇　や076△△△
といった具合です。

これも外していたらごめんなさいね。m(_ _)m

お礼

ありがとうございます
今度作るときはそうします
大変助かりました

回答No.4

keithin

はて？
＞オートシェイプがずれる

回答１のマクロと、回答２のマクロの、本当に間違いなく両方のマクロを試して、両方とも同じくズレたのですか？

ま、いずれにしても。
出自の異なる（とは、簡単に言えばたとえば「別のパソコンのエクセルで作成した」といった状況のことです）複数のブックから、無理矢理今回のように一つのブックに束ねようとすると、そういったことが起きる可能性があります。
マクロの問題ではなく「ブック自体が悪い」ので、今の状況から「そうならないようにする」方法はありません。

ここから修繕するのは事実上「まっさらブックから全部のデータを作り直す」のと同じことなので、今はとりあえず「統合」だけ果たし、ずれたモノは許容できる範囲で修正してご利用になった方が正解です。

補足

両方とも試して、両方ともずれていました
しかも全部ではなく幾つかなんです

出自が異なるとはなんですが

一つは私がもう一つは別の人がマックで作ったものです

私が作ったものとマックで作ったものの
どちらも全部ではなく幾つかだけずれてしまいます。

keithinさんのおっしゃるとおり

今はとりあえず「統合」だけ果たし、ずれたモノは許容できる範囲で修正して使ってみます
本当にありがとうございました
大変助かりました

回答No.3

tom04

No.2です！
補足の件について・・・
（1）の
＞シートに入っているオートシェイプが全部ではなく、左に幾つかずれてしまいます
に関しては元Sheetの「オートシェイプの書式設定」の「オブジェクトの位置関係」で
「セルに合わせて移動やサイズを変更しない」にしてみてはどうでしょうか？
それを一つ一つ手作業でやるもの大変だと思いますので、

無理矢理とってつけたようなコードになりますが、
前回のコード内の
＞For k = 1 To myArray(j).Worksheets.Count
＞str = myArray(j).Worksheets(k).Name
の2行の間に
＞Dim S As Shape
＞For Each S In myArray(j).Worksheets(k).Shapes
＞S.Placement = xlFreeFloating
＞Next S
の3行を挿入してみてください。

これで元Sheetのオートシェイプは「セルに合わせて・・・変更しない」になると思います。

次にID番号の順番が変わってしまう！という件ですが、
考えられる原因といえばSheet順が変わったことにより表示順も変わってしまった。
というコトです。

元データがどのような状態なのか把握できないので、原因がはっきり判らないのですが、
関数等で別Sheetを参照してIDを表示されていますか？
もしそうであっても通常はSheet名が関数に入っているので問題はないと思います。

もし、マクロでSheet名ではなくインデックス番号でSheetを指定し、IDを表示させている場合は
そのようなことも考えられますが、
それが直接の原因かどうかは判りません。

この程度であまりお役に立てないのですが、ごめんなさいね。m(_ _)m

お礼

いえいえ、大変助かります
嬉しいです

回答No.2

tom04

こんばんは！
一例です。
まっさらなBookの標準モジュールにコピー＆ペーストしてマクロを実行してみてください。

Sub test()
Dim i, j, k As Long
Dim wb1, wb2 As Workbook
Dim ws As Worksheet
Dim str As String
Dim myArray As Variant
Set ws = Worksheets(1)
Set wb1 = Workbooks("Book1.xlsx")
Set wb2 = Workbooks("Book2.xlsx")
myArray = Array(wb1, wb2)
Worksheets.Add before:=Worksheets(1)
For j = 0 To 1
For k = 1 To myArray(j).Worksheets.Count
str = myArray(j).Worksheets(k).Name
If str Like "パターン*" Then
ws.Cells(Rows.Count, 1).End(xlUp).Offset(1) = _
1 & myArray(j).Worksheets(k).Name
Else
ws.Cells(Rows.Count, 1).End(xlUp).Offset(1) = _
myArray(j).Worksheets(k).Name
End If
Next k
Next j
ws.Columns(1).Sort key1:=ws.Cells(1, 1), order1:=xlAscending
For i = 1 To ws.Cells(Rows.Count, 1).End(xlUp).Row
If ws.Cells(i, 1) Like "1*" Then
ws.Cells(i, 1) = Mid(ws.Cells(i, 1), 2, Len(ws.Cells(i, 1)))
End If
Next i
For k = 1 To ws.Cells(Rows.Count, 1).End(xlUp).Row
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = ws.Cells(k, 1)
Next k
For j = 0 To 1
For i = 1 To Worksheets.Count
For k = 1 To myArray(j).Worksheets.Count
If Worksheets(i).Name = myArray(j).Worksheets(k).Name Then
myArray(j).Worksheets(k).Cells.Copy Destination:= _
Worksheets(i).Cells(1, 1)
End If
Next k
Next i
Next j
For k = Worksheets.Count To 1 Step -1
Application.DisplayAlerts = False
If Worksheets(k).Name Like "Sheet*" Then
Worksheets(k).Delete
End If
Application.DisplayAlerts = True
Next k
End Sub

※　Book1・Book2は開いたうえでマクロを実行してください。
参考になりますかね？m(_ _)m

補足

ありがとうございます
やってみたのですが、シートに入っているオートシェイプが全部ではなく、左に幾つかずれてしまいます

また、ID名に132と76などの数字が入っていると132の方が前にきてしまいます。

上記二点の修正の仕方も教えて頂けないでしょうか？
よろしくお願い致します。

回答No.1

keithin

丁寧に調査して並べ替えるだけの作業です。
マクロのご質問ですから，最低限マクロの使い方はご存じですね。

準備：
（いわずもがなですが，ファイル名とか拡張子とかは適切に作成しなければなりません）
Book1.xlsxとBook2.xlsxがあるとして
それぞれのブックを開いておいて
加えてbook3.xlsmを用意，book3.xlsmに標準モジュールを用意して下記を記入し実行する。

sub macro1()
　dim w(1) as variant
　dim s0 as worksheet
　dim s as worksheet
　dim h as range
　dim i as integer

’準備する
　set w(0) = workbooks("Book1.xlsx")
　set w(1) = workbooks("Book2.xlsx")
　thisworkbook.activate
　set s0 = thisworkbook.worksheets.add(before:=thisworkbook.worksheets(1))

’調査する
　s0.range("A1:C1") = array("book name", "sheet name", "seg1-seg2")
　for i = 0 to 1
　for each s in w(i).worksheets
　　with s0.range("A65536").end(xlup).offset(1)
　　　.value = w(i).name
　　　.offset(0, 1).value = s.name
　　　.offset(0, 2).value = strconv(iif(s.name like "パタ?ン*",replace(s.name,left(s.name, 4)," パターン-"),s.name), vbnarrow)
　　end with
　next
　next i

’並べ替える
　range("C:C").texttocolumns _
　　destination:=range("C1"), _
　　datatype:=xldelimited, _
　　otherchar:="-"
　range("A:D").sort _
　　key1:=range("C1"), order1:=xlascending, _
　　key2:=range("D1"), order2:=xlascending, _
　　header:=xlyes

’収集する
　for each h in range("A2:A" & range("A65536").end(xlup).row)
　workbooks(h.value).worksheets(h.offset(0, 1).value).copy after:=thisworkbook.worksheets(thisworkbook.worksheets.count)
　next

’片付ける
　application.displayalerts = false
　for each s in thisworkbook.worksheets
　　if s.name like "Sheet*" then s.delete
　next
　application.displayalerts = true
　thisworkbook.worksheets(1).select

end sub

補足

ありがとうございます
統合はできたのですが
シートに入っているオートシェイプが
統合する前のファイルと比べると
全シートではないのですが
幾つかそれもかなりの数（半分くらい）
左に少しずれてしまうのですが
これはずれないで統合することはできないのでしょうか?

拡張子がxlsxではなくxlsなのも関係しているのでしょうか？