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

質問

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

　下記は二つのファイルの構成を比較して（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行位まで）と作成済みのファイルから差分を求めて、以下処理するという勉強をしたいと思いました。今回は、助かりました。よく行き詰るのでその際は、またお知恵を貸して下さい。