配列処理を遅くてもよいので軽い処理に変えたい。

質問

よろしくお願いします。
　抜粋のコードをメモリーに負荷をかけない処理に変えたいのです。

　下記は二つのファイルの構成を比較して（OLDBOOKのシートをNEWBOOKと同じ構成にする）追加、削除、並び替えを行うというものです。
しかし、メモリーの問題でシート数が30を超えると（環境によっては40枚位まではOK）Sheets.Countが狂い結果エラーに結び付くのです。
そこで、メモリーの負担を軽くするため、一気に配列に呼び込むのではなく、遅くなってもいいので、一つずつ比較するやりかたをご教示願えないかという次第です。
　なお補足ですが、シートは関数などがぎっしり書き込まれているので、重いものなのです。それをBOOKに出来れば100枚位まで入るようにしたいのです。
　ネット上で「一つのBOOKに何枚までシートを挿入出来るか？」というのを見ましたが、やはりメモリーに依存し（物理メモリーではなく）空のシートなら65000枚とかまででもOKですが、重いシートだと30枚位からダメになるとありましたので、実は今回の省略の前の部分でシートをCopy Afterで別BOOKに追加していくという形が有ったのですがここでもエラーでした。その内容はやはりSheets.Countが30を過ぎたら狂い（50枚入れる指示にもかかわらず31枚目を挿入時、シートカウントが7とかに戻ってしまう）そこで必要な枚数をCopy Afterで挿入して行かずに、先に空シートを必要な枚数作らせたBOOKのシートをまとめて、今回のシートを貼り付ける作業に変えたところ、100枚でもOKになり、そこはクリアしたのですが、今回の抜粋の所で引っかかってしまいました。
同じように遅くなっても軽い処理に下記コードを直したいのです。助けて下さい。

Dim NEWBOOK As Workbook
Dim OLDBOOK As Workbook
Dim shSrc As Object
Dim shDst As Object
～省略 ～
'現在の再計算モードの取得
iOldCalculation = Application.Calculation

'再計算モードを手動に設定
Application.Calculation = xlManual

'*****ここから比較*****

' // まず NEWBOOK にあって OLDBOOK にないシートをOLDBOOK に複写
For Each shSrc In NEWBOOK.Sheets
On Error Resume Next
Set shDst = OLDBOOK.Sheets(shSrc.Name)
On Error GoTo 0
If shDst Is Nothing Then
shSrc.Copy After:=OLDBOOK.Sheets(OLDBOOK.Sheets.Count)　　　←ここで実行時エラー（1004　コピー先の行数が足りないため～）
End If
Set shDst = Nothing
Next

' // 続いてNEWBOOK　になくてOLDBOOK にあるシートをOLDBOOK　から削除
For Each shDst In OLDBOOK.Sheets
On Error Resume Next
Set shSrc = NEWBOOK.Sheets(shDst.Name)
On Error GoTo 0
If shSrc Is Nothing Then
shDst.Delete
End If
Set shSrc = Nothing
Next

' // シート並べ替え
For Each shDst In OLDBOOK.Sheets
shDst.Move Before:=OLDBOOK.Sheets(NEWBOOK.Sheets(shDst.Name).Index)

shDst.Protect DrawingObjects:=True, Contents:=True, UserInterfaceOnly:=True
Next

'再計算モードの復元
Application.Calculation = iOldCalculation

NEWBOOK.Close (False) '有無を言わずに保存せず閉じる

～省略 ～

回答No.2

end-u · ベストアンサー

Excelのバージョンは何ですか？

一応、違うアプローチで以下のようなものが考えられますが
Sub try()
　　Dim NEWBOOK As Workbook
　　Dim OLDBOOK As Workbook
　　Dim wb　　　As Workbook
　　Dim sh　　　As Object
　　Dim dic　　 As Object
　　Dim i　　　 As Long
　　Dim oldname As String
　　Dim iOldCalculation As Long

　　'現在の再計算モードの取得
　　iOldCalculation = Application.Calculation
　　'再計算モードを手動に設定
　　Application.Calculation = xlManual

　　'Set OLDBOOK = Workbooks("oldbook.xls")
　　'Set NEWBOOK = Workbooks("newbook.xls")
　　'OLDBOOKシート名をdictionaryに登録
　　Set dic = CreateObject("scripting.dictionary")
　　For Each sh In OLDBOOK.Sheets
　　　　dic(sh.Name) = Empty
　　Next
　　'新規Bookを追加
　　Set wb = Workbooks.Add(xlWBATWorksheet)
　　wb.Sheets(1).Name = "dummy"

　　'NEWBOOKのシートをLoopして名前がdictionaryにあれば OLDBOOKから _
　　 なければ NEWBOOKから新規Bookに移動する。
　　With NEWBOOK
　　　　For i = .Sheets.Count To 1 Step -1
　　　　　　With .Sheets(i)
　　　　　　　　If dic.exists(.Name) Then
　　　　　　　　　　OLDBOOK.Sheets(.Name).Move before:=wb.Sheets(1)
　　　　　　　　Else
　　　　　　　　　　.Move before:=wb.Sheets(1)
　　　　　　　　End If
　　　　　　End With
　　　　Next
　　End With

　　oldname = OLDBOOK.FullName
　　OLDBOOK.Close False　　　　　　　 '保存せず閉じる
　　NEWBOOK.Close False　　　　　　　 '保存せず閉じる

　　Application.DisplayAlerts = False
　　wb.Sheets("dummy").Delete　　　　 'wbの初期シートを削除
　　'wb.SaveAs oldname　　　　　　　　 'OLDBOOK.FullNameで強制上書き保存
　　Application.DisplayAlerts = True
　　'再計算モードの復元
　　Application.Calculation = iOldCalculation

　　Set dic = Nothing
　　Set NEWBOOK = Nothing
　　Set OLDBOOK = Nothing
　　Set wb = Nothing
End Sub

>シートは関数などがぎっしり書き込まれているので、重いものなのです。
>それをBOOKに出来れば100枚位まで入るようにしたいのです。
という仕様に無理があるのかもしれませんね。

お礼

end-uさんへ
今拝見しました。
今から明日まで出張のため、非常に残念ながら、即、検証出来ませんが、明日の夜には戻るので、明後日までには必ず検証して報告致します。
取り急ぎお礼申し上げます。それでは。

補足

昨日まで出張になりまして、返事が遅くなりました。すいません。
検証の結果、今回のきもの部分　If dic.exists(.Name) Thenの判定及びそれ以下のそれぞれの処理OKです。（問題はCopy Afterで重いシートを大量に貼り付けることにあり）有難うございます。
CreateObjectは使ったことがありませんでした。なるほどそういうのもありかと思った次第です。感謝です。発想が膨らみました。そこで今回取り上げた以外のもので、作成する予定のリストを連想配列（1行に4列で（名前がKeyで他3つのItems）2行目から100行位まで）と作成済みのファイルから差分を求めて、以下処理するという勉強をしたいと思いました。今回は、助かりました。よく行き詰るのでその際は、またお知恵を貸して下さい。

回答No.3

end-u

解決済みのようですが、念の為蛇足しておきますね。
今回のキモはMatch判定の箇所ではなく、
>Set wb = Workbooks.Add(xlWBATWorksheet)
>.Move before:=wb.Sheets(1)
つまり、
『旧Bookが2003互換、新Bookが2007バージョンのケースで、2007で実行した場合』
を想定すると、旧Bookへシートコピーできませんから、
2007で新規Bookを追加して、そこにMoveメソッドでシートを集約するというアプローチです。

>（実行時エラー1004　移動先またはコピー先の行列数が元のブックより少ないため、シートを挿入出来ない?）
というメッセージを言葉通りに受け取って、そんな想定をしてみました。
なので最初に『Excelのバージョンは何ですか？』とお訊きしてみたのですが。

ただ、想定通りなら、ちと失敗してる箇所があります。
>'wb.SaveAs oldname　　　　　　　　 'OLDBOOK.FullNameで強制上書き保存
一応コメントにしてましたが、ここをそのまま非コメントにして実行すると、
拡張子がOLDBOOK.FullNameのままなので、ファイルの実態と拡張子が合わないので
次回開く時にメッセージが出ます。

なので本当に
『旧Bookが2003互換、新Bookが2007バージョンのケースで、2007で実行した場合』
が原因なのか再度確認しておかれたほうが良いです。
その場合は、保存時の wb.SaveAs oldname の oldname を工夫しておいたほうが良いでしょう。
他にもあったので修正版再掲しておきます。

Sub try2()
　　Dim NEWBOOK As Workbook
　　Dim OLDBOOK As Workbook
　　Dim wb　　　As Workbook
　　Dim sh　　　As Object
　　Dim dic　　 As Object
　　Dim i　　　 As Long
　　Dim oldname As String
　　Dim iOldCalculation As Long

　　'現在の再計算モードの取得
　　iOldCalculation = Application.Calculation
　　'再計算モードを手動に設定
　　Application.Calculation = xlManual

　　Set OLDBOOK = Workbooks("oldbook.xls")
　　Set NEWBOOK = Workbooks("newbook.xlsx")
　　oldname = OLDBOOK.Path & "\" _
　　　　& CreateObject("scripting.filesystemobject").GetBaseName(OLDBOOK.FullName)
　　'OLDBOOKシート名をdictionaryに登録
　　Set dic = CreateObject("scripting.dictionary")
　　For Each sh In OLDBOOK.Sheets
　　　　dic(sh.Name) = Empty
　　Next
　　'新規Bookを追加
　　Set wb = Workbooks.Add(xlWBATWorksheet)
　　wb.Sheets(1).Name = "dummy"

　　'NEWBOOKのシートをLoopして名前がdictionaryにあれば OLDBOOKから _
　　 なければ NEWBOOKから新規Bookに移動する。
　　With NEWBOOK
　　　　For i = .Sheets.Count To 1 Step -1
　　　　　　With .Sheets(i)
　　　　　　　　If dic.exists(.Name) Then
　　　　　　　　　　OLDBOOK.Sheets(.Name).Move Before:=wb.Sheets(1)
　　　　　　　　Else
　　　　　　　　　　.Move Before:=wb.Sheets(1)
　　　　　　　　End If
　　　　　　End With
　　　　Next
　　End With

　　'全シートが移動した場合はerror対策必要
　　On Error Resume Next
　　OLDBOOK.Close False
　　NEWBOOK.Close False
　　On Error GoTo 0
　　Application.DisplayAlerts = False
　　wb.Sheets("dummy").Delete　　　　 'wbの初期シートを削除
　　wb.SaveAs oldname　　　　　　　　 'OLDBOOK.FullNameで強制上書き保存
　　Application.DisplayAlerts = True
　　'再計算モードの復元
　　Application.Calculation = iOldCalculation

　　Set dic = Nothing
　　Set NEWBOOK = Nothing
　　Set OLDBOOK = Nothing
　　Set wb = Nothing
End Sub

お礼

end-uさん。今拝見しました。本当に頭が下がる思いです。実は、この件は解決しましたが、（BOOK実体同士の比較ではなく作成予定リストとBOOK実体との比較式←場合によってはdictionaryで代用｛以前教えてもらったこと｝）その後、エクセルのVerコードが両立しない（当方の中身は2本立てで、2007用はメモリーの制限が少ないので親BOOK（互換）からシートをCopyして必要分追加挿入して、それに中身を書き込む行程ですので問題は起きませんが。←100枚位までは。けれど2003用だとメモリー依存問題で重いシートだと約30枚位でカウントが狂うために、とても遅くはなるのですが新規BOOKに必要分シートを増やしてから原本を貼り付け、それに一枚一枚中身を記入して行く行程です。なので2003用で作成したものは2003でOKでも2007で検証するとエラー）ことに気付いて、その件でググッてたところ（OKWAVEは見てなかった）私の以前の質問に更にレスが付いているで驚きました。また内容もど真ん中です。私はメインで2007を使用し（作成物は互換モード）たまに2000で動作チェックしてから、各営業所（2003と2007混在）に配布したりします。環境によって変わるのはある程度予見出来てるつもりでしたが、この点はうっかりしてました。実行時エラーのコメントに最初から違和感を持ってはいましたが‥そうですよね。新規BOOKを作成させた時点ではそのVerになるのですね。それを互換Verに突っ込んだりするわけですから、2007からは2003には入らないということですね。気付かない時は気付かないもので、かなり試行錯誤していました。助かりました。2本立ては管理が面倒なので、統一のため
1.マクロブック（親）の適当なシート（互換モード）からCopyで新規BOOKを作成
2.Addで新規を作り（環境によりVerが違うが）判定により互換モードでなければ、一旦互換モードでSaveして、再度呼び出し使用する。（遅そうですね）
のどちらかで進めたいと思います。しかしメモリー問題なんとかならないのでしょうか？100枚位にSheets.Selectして貼り付けるとパソコン壊れたんじゃないかと思われ、強制終了されてしまいそうなくらい時間ががかかります。余談でした。
　本題に戻して、今回は、終了の質問にもレス頂け、本当にありがとう御座います。またOKWAVEでもお世話になると思いますが、よろしくお願いします。有難うポイント100点です。
ファンになりました。yokokama46

回答No.1

redfox63

NEW->OLDの際に引数Afterに Worksheetオブジェクトを設定したら上手くいくかも

dim shAfter as worksheet

if shDst is nothing then
　　if shAfter is Nothing then
　　　　set shAfter = OLDBOOK.Sheets(OLDBOOK.Sheets.Count)
　　end if
　　shSrc.Copy after:= shAfter
　　set shAfter = OldBook.Sheets( shSrc.Name )
　　' ↑でこけるとどうしようもないですが …
end if

お礼

2日続けて助けてくれて有難うございました。感謝してます。しばらく配列処理関係で、行き詰る気がしますので、その際はまた助けて下さい。今後もよろしくお願いします。

補足

redfox63さん　昨日に引き続きお世話になります。20分位前に拝見しました。
早速検証したところ、こけました。
shSrc.Copy after:= shAfterでこけます。（実行時エラー1004　移動先またはコピー先の行列数が元のブックより少ないため、シートを挿入出来ない～）
今回はOLDBOOKは50枚のシートに対してNEWBOOKは約100枚のシートで検証してます。イミディエイトで確認したところ２行上のset shAfter = OLDBOOK.Sheets(OLDBOOK.Sheets.Count)のシートカウントは50（50枚あるのでOK）　
今回の設定ではNEWBOOKの1枚目はOLDBOOKにはないので、普通OLDBOOKの51枚目に挿入になっても良いと思うのですが、ここで上記のエラーとなります。
またエラー時のコメントに違和感があります。ネット上でもメモリー依存のことは多く載ってましたが、結果、このコメントとは載ってません。もちろん今回はまさにメモリー問題のど真ん中のシート構成ですが、先が元より少なくても追加するのに問題があるの？という感じを受けてます。私は詳しい方ではないので？？？悩みまくりです。
またまた助けて下さい。