Excel vba でメモリが不足しています。っと表示されて処理が完了できない。

###最終　--2018.11.16 13:40　追記 --
回避策...
手動、マクロ問わずに大量のセルに対し操作の必要があるときは
「カメラ」機能やリンクされた図は使用しない
又は、
一度閉じると使用メモリが元に戻るので
目視、又はpowershell 等を用いて使用メモリが一定量を超えたら
Excelプロセスを再起動してから作業を続行する...

「カメラ」機能やリンクされた図は使用しないのが王道でしょうか
他にも不具合がいっぱいあるようですし
便利な機能なのでとても残念です.....

###現在の状況　--2018.11.16 11:35　追記 --
sazi 様からのコメントで分かったのですが
カメラ機能でなくても
貼り付けオプションの「リンクされた図」でも
同様の症状が出ることが分かりました。

###現在の状況　--2018.11.16 11:20　追記 --
検証を重ねた結果
メモリの上昇量には一応上限があることが分かりました。
カメラの範囲の他
入力されている数式の数計算量?
等に影響されることが分かりました。
Win10 Excel 2013 32bit でも確認しました。

###現在の状況　--2018.11.16 10:40　追記 --
原因の特定が出来ました。
Excelの「カメラ」機能を使用して作成したオブジェクトが存在すると
本文記載の問題が発生するようです。

Win10 Excel 2016 64bit で
新規ブックのみを立ち上げ確認致しました。

そのオブジェクトは
0. 適当なセル10個ほど選択
0. 「カメラ」をクリック
0. 適当なセルクリック
で配置しました。

出来れば引き続き「カメラ」機能は使いたいのですが
回避方法はないのでしょうか?
また、症状の再現が出来た方、出来なかった方
環境を教えて頂きたいです。
お願い致します。

「カメラ」機能はクイックアクセスツールバーに追加して利用しました。

###現在の状況　--2018.11.16 09:47　追記 --
いろいろ検証をした結果
コードだけに問題があるわけではなく
Excelファイルが異常をきたしているのか
特定条件下のでの Excelの挙動が問題になっている可能性が高いことが分かりました。

発生している症状は

特定のブックを開いている状態で同じプロセス内の任意のブックの任意の
セルの設定(塗りつぶし、ユーザー定義書式等)を書き換えるだけで
その都度使用メモリが増加する。

手動で適当なブックの適当なセルを選択してセルの塗りつぶしボタンを連打するだけでも同様に発生

特定のブックは開かず新規のブックのみ開いて手動でセルの塗りつぶしボタンを連打しても
使用メモリは増加しますが
おそらく戻るボタンの履歴の関係だと思うのですが　そちらは一定以上は上がりません。

特定のブックを開いていると下記のコードを実行しただけでメモリ不足のエラーが表示されます。

vba
1Sub test()
2
3    Dim i As Integer
4    For i = 1 To 10000
5        Selection.NumberFormat = Selection.NumberFormat
6    Next i
7End Sub

他気になる点は
上記コード実行時はExcelのCPU 使用率が10％強くらいまでしか上がらず
(未保存新規ブックのみ起動の場合は30%くらいまで使用率が上がり、すぐ終わる)
実行速度が極端に低下することです。

現在状況を再現できないか確認しています。

前提・実現したいこと

発端は
Excel ブック(ファイル)に問題があるのか頻繁にデータが壊れて
修復しますか?と表示される。
修復を選択すると開けるがセル幅が全て同じ幅になってしまったりして　まともに修復できていない。
そんな状態を何とかしたい...
過去に同様の現象が起きたときはブックを新規作成(シートをコピーしたらだめだった)して作り直したら再発しなくなったので、
そうしようと思ったのですが量が多い...

そのためマクロで書式設定等を移してしまおうと思ったのですが
メモリが不足していますと表示されて途中までしか実行できません。

メモリが不足と表示されてしまう原因が全く分からず
今回はいつこの問題が解決できるかもわからないので諦めて手動で作り直そうかと思うのですが、
今後の対策のためにも原因が知りたいです。

極力コードを削って確認してみたのですが
Get_Set_CellInfo 内の塗りつぶし　や　削ったため下記のコードにはないですが
罫線の設定、ユーザー定義書式の設定などでも同様にメモリ不足と表示されます。

タスクマネージャで見てみたのですが　パソコン全体のメモリは余裕があるようでした...

発生している問題・エラーメッセージ

該当のソースコード

Book1の全ての使用済みセルに対しての処理
処理は結合範囲ごと(セルをひとつずつ確認して結合セル範囲の左上だった時のみ)

vba
1
2Sub SHC()
3
4    Const BaseNm As String = "Book1.xlsx"
5    Const TargetNm As String = "Book2.xlsx"
6    
7    Dim Base As Workbook
8    Set Base = Workbooks(BaseNm)
9    
10    Dim Target As Workbook
11    Set Target = Workbooks(TargetNm)
12    
13    Dim BaseCt As Integer
14    BaseCt = Base.Sheets.Count
15    
16    Dim i As Integer
17    
18    
19    Application.EnableEvents = False
20    Application.Calculation = xlCalculationManual
21    
22    Dim Result As Variant
23    
24    For i = 1 To BaseCt
25    Debug.Print i
26        Get_Set_CellJoin Base.Sheets(i), Target.Sheets(i)
27    Next i
28    Application.EnableEvents = True
29    Application.Calculation = xlCalculationAutomatic
30    
31End Sub
32
33Sub Get_Set_CellInfo(BRng As Range, TRng As Range)
34
35    If BRng.MergeCells Then
36        TRng.Merge
37    End If
38
39' 塗りつぶし
40    TRng.Interior.Pattern = BRng.Interior.Pattern
41    If Not BRng.Interior.Pattern = xlNone Then
42        TRng.Interior.Color = BRng.Interior.Color
43    End If
44
45End Sub
46
47
48Sub Get_Set_CellJoin(BSh As Worksheet, SSh As Worksheet)
49'セルの書式
50
51    Dim Rng As Range
52    Set Rng = BSh.UsedRange
53    
54    Dim Row As Long
55    Row = Rng.Rows.Count
56    
57    Dim Col As Long
58    Col = Rng.Columns.Count
59    
60    Dim R As Long
61    Dim C As Long
62    
63    Dim TCell As Variant
64    
65    For R = 1 To Row
66        For C = 1 To Col
67            
68            If Rng(R, C).Address(False, False) = Rng(R, C).MergeArea(1, 1).Address(False, False) Then
69                Debug.Print Rng(R, C).MergeArea.Address(False, False)
70                Get_Set_CellInfo Rng(R, C).MergeArea, SSh.Range(Rng(R, C).MergeArea.Address(False, False))
71            End If
72            
73        Next C
74    Next R
75    
76End Sub

試したこと

For each で回しているのが悪いのかと思いfor に書き直してみた
途中でブックの保存を挟んでみた
Set を使っているものに対しては各プロシージャの最後で　set 変数 = nothing をしてみた
パソコンを再起動してみた
ステップインで一つずつステートメントを実行してみた
罫線等の設定でも同様になる

--追記--
mdj　様の「1シート処理するように書き換えてみて、検証するのはどうでしょうか。」の言葉で
目的のブック以外に同様の操作をした場合に同じ現象が起きるかどうかの検証をしていないことに気づいたので、
容量が多い別のファイル(数式は殆ど入っていない)で　検証をした結果
そちらでは同様の問題は発生しませんでした。

--追記--
プログラムエラーとは別に新規作成から作り直していたExcelブックの件で、
7時間くらいかけてなんとか元のブックと見分けがつかないくらいまで作ったのですが
2018.11.15 現在壊れているのを確認しました....

仮定していた「長年(拡張子が .xls だったころから)使ってきたので
ブックのどこかがおかしくなっていて壊れやすくなっている」という可能性が低くなりました。

「代わりに特定条件下で壊れやすくなっている」可能性が高くなったので
プログラムエラーの件と合わせて再現可能か確認してみます。

他のブックとの違いといえば他のブックへの参照と他のブックからの参照があり
尚且つそのデータを使ったグラフがある事くらいだと思うのですが...

--追記--
見かけそっくりに作り直した方のデータ(一度壊れて再び修復中のためグラフがない　あと他ブックへのリンクが切れているかも...)に対しては
使用メモリが増え続ける現象は起きませんでした。

--追記--
メモリがパンクする前に中断した場合そのExcelプロセスを閉じるまで(ブックを閉じても)メモリはそのままでした。
開きなおすと増加してしまった使用メモリは元に戻っていました。

問題のブックのセル設定の読み込みのみ(variant 変数への代入)のみ行った場合は使用メモリの増加は発生しませんでした。

問題のブックを開いた状態で同じプロセス上の関係のないブックのセルの設定を書き換えて見たら使用メモリの増加が発生しました。

どうやら　問題のブックを開いている状態で同じプロセス内のブックのセルの設定を書き換えるだけで
使用メモリが増加してしまうようです。

--追記--
問題のブックを開いている場合
手動で適当なブックの適当なセルを選択してセルの塗りつぶしボタンを連打するだけでも
使用メモリが増加することが確認できました....

問題のブックは開かず新規のブックのみ開いて同様の内容を行っても
使用メモリは増加しますが
一定以上は上がりません。

そちらはおそらく履歴(戻るボタンで戻るための分)で増えただけだと思われます。

補足情報（FW/ツールのバージョンなど）

Win10
Excel 2016 64bit

Book1の情報
拡張子 xlsx
ファイルサイズ　112 KB
各シートのUsedRange
シートインデックス = 1 : 行数 = 57 : 列数 = 54
シートインデックス = 2 : 行数 = 36 : 列数 = 73
シートインデックス = 3 : 行数 = 34 : 列数 = 73
シートインデックス = 4 : 行数 = 34 : 列数 = 73
シートインデックス = 5 : 行数 = 57 : 列数 = 11
シートインデックス = 6 : 行数 = 40 : 列数 = 22
シートインデックス = 7 : 行数 = 31 : 列数 = 15
シートインデックス = 8 : 行数 = 20 : 列数 = 18

グラフ1(折れ線グラフ)
数式多数使用　(他のブックへの参照と他のブックからの参照多々あり)

行動規範の内容に同意します

回答4件

他人の書いたコードは読みにくいので、自分流に直してしまいました＾＾；
やりたいことはこういうことかな？
動作確認はしてません。意を汲み取っていただけると幸いです。

VBA
1Sub SHC()
2    Dim wbOld As Workbook
3    Dim wbNew As Workbook
4    Dim ws As Worksheet
5    Dim rngTarget As Range
6
7    Set wbOld = Workbooks("Book2")
8    Set wbNew = Workbooks("Book1")
9
10    For Each ws In wbOld.Worksheets
11        Set rngTarget = Get_CellJoin(ws, wbNew.Sheets(ws.Index))
12        rngTarget.Interior.Color = ws.Range(rngTarget.Areas(1).Address).Interior.Color
13    Next
14End Sub
15
16'結合セルの取得
17Function Get_CellJoin(wsFrom As Worksheet, wsTo As Worksheet) As Range
18    Dim c As Range
19    Dim rng As Range
20    
21    For Each c In wsFrom.UsedRange
22        If c.MergeCells Then
23            If c.Address = c(1).Address Then
24                wsTo.Range(c.MergeArea.Address).Merge
25                If rng Is Nothing Then
26                    Set rng = c
27                Else
28                    Set rng = Union(rng, c)
29                End If
30            End If
31        End If
32    Next
33    Set Get_CellJoin = rng
34End Function

投稿2018/11/15 11:24

mattuwan

総合スコア2167

質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう！

前提・実現したいこと

発生している問題・エラーメッセージ

該当のソースコード

試したこと

補足情報（FW/ツールのバージョンなど）

関連した質問