VBAのエラーで、セルの書式が多すぎるため書式を追加できません。

Question

Excel２００３のＶＢＡで質問です。
複数ブック→1つのブックで複数シート　にするマクロを作成しています。
今まではうまく実行できていたのですが、
wb.Sheets("12月").Range("A1:AO45").Copy
mb.Sheets(mb.Sheets.Count).Range("A1").Select 
mb.Sheets(mb.Sheets.Count).Paste
を追加したところ、途中までは大丈夫なのですが、ある一定数以上のブックで
「セルの書式が多すぎるため書式を追加できません」とメッセージが出ます。
VBAのどの辺りを修正すればよいのでしょうか？
また、都度
「コピーまたは移動先セルの内容を置き換えますか？」や「クリップボードにおおきな情報があります。この情報を貼り付けられるようにしますか？」などに「Y」や「N」を都度入力しなくてもよいようにできますでしょうか？

以上、よろしくお願いします。

下記は全マクロ。
Sub Consolid03()
Dim mb As Workbook, wb As Workbook
Dim myfdr As String, fname As String, n As Integer
Application.ScreenUpdating = False '画面更新を一時停止
Set mb = ThisWorkbook 'このコピー先ブックをmbとする。
myfdr = ThisWorkbook.Path
fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索
Do Until fname = Empty '全て検索
If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ
Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。
wb.Sheets("12月").Copy After:=mb.Sheets(mb.Sheets.Count) '開いたシートをコピーしてmbの末尾に置く
wb.Sheets("12月").Range("A1:AO45").Copy
mb.Sheets(mb.Sheets.Count).Range("A1").Select 'コピー先シートを選択してアクティブにする
mb.Sheets(mb.Sheets.Count).Paste
wb.Close (False) '有無を言わずに保存せず閉じる
mb.Sheets(mb.Sheets.Count).Unprotect Password:="9" 'パスワード解除
For Each c In mb.Sheets(mb.Sheets.Count).UsedRange '取り込んだシートの使用範囲に
If c.FormulaR1C1 Like "=*!*" Then '他シート参照があれば
c.Value = c.Value '値に変更
End If
Next
n = n + 1 'ブック数をカウント
End If
fname = Dir 'フォルダ内の次のExcelブックを検索
Loop '繰り返す
Application.ScreenUpdating = True '画面更新一時停止を解除

Dim ws As Worksheet '全てのシートの色をなしにする
For Each ws In Worksheets
ws.Tab.ColorIndex = xlColorIndexNone
Next
MsgBox UCase(Environ("UserName")) & "さん、" & n & "件のブックをコピーしましました。" _
+ Chr(&HD) + Chr(&HA) + "他シートを参照する式だけは値にしておきましたよ。" _
+ Chr(&HD) + Chr(&HA) + "" _
+ Chr(&HD) + Chr(&HA) + "", , "（￣ー￣）v "
End Sub

avanzato · Accepted Answer

確認が遅くなりました。
#1です。
セルの書式を4000パターン作成するプログラムを作りテストを行いました。
大体3700～3800パターンまで行った所で質問のエラーが発生しそれ以降の処理が進まなくなることを確認しました。
また、マイクロソフトサポートにも記事がありました。
http://support.microsoft.com/kb/213904/JA/
一連の処理の中でパターンの最大数をカウントしているため、仮に2000パターンまで行った所で書式をデフォルトに変更してもカウントを減らすことが出来ません。
マイクロソフトの提示している方法は「ブック内の書式の簡素化または標準化を行った後、ブックを保存して閉じ、再度開いてから、新たなセルの書式設定を適用してください。 」ですのでそれに従った方法が必要になります。
ただし、ブックを保存して閉じ、再度開いてからとなると手動操作が必要になります。
処理を別のブックから行えば可能かもしれませんがテストもしていないですし事例も無い為確証が取れません。
まとめたい複数ブック・まとめるブック・管理用のブックの構成でという方法ですが微妙な感じです。

視点を変えて、予めまとめたい複数ブックの書式を統一した書式（デフォルト書式）にしておけばこのエラーは出ないのかもしれません。

参考までに。

Wendy02 · Answer

こんばんは。

まず、いろいろ検討させていただきましたが、現段階では、マクロの設計の仕方そのものを変えないといけないと思います。

おそらく、そのファイルは、それぞれ年数の違うもので、いろんな書式やいろんな作り方が含まれているもので、コピーした後に、すべての書式を、マクロで設定し直さないといけないのですが、見ないで設定するのはむつかしいです。もしも、一定のフォームで作られたものなら、そのようなエラーは発生しないはずです。

せめて、フォントの種類を標準にする、フォントサイズを標準にするというような作業工程を加えないといけないと思います。ある程度の書式設定を、一旦削除して、作りなおさないといけないようです。原因は、きちんと特定できた方がよいと思います。

そうしないと、現状のままでは解決は難しいと思います。

いくつかのポイントに対して、回答とコメントを書かせていただきます。

・For Each c In mSh.UsedRange.SpecialCells(xlCellTypeFormulas).Cells
のエラー自体は、こちらは、数式がないということ自体を想定していませんでした。それは、簡単に直せます。On Error Resume と On Error Goto 0 で挟みます。こういうものは、千変万化というか、それを予め想定するのはできませんので、実際のものを見るまでは、なんとも言えません。データと一緒に、様々の書式を確保していくのは、Excelでは難しいです。本来は、CSVのようなテキスト型にして、保存するのがベストです。

・シート名の12月（2）,12月（3）というのは、本来は、拡張子抜きのファイル名(BaseName)が入るものが良いのではないかと推測しています。ファイル名は、システム・トラブルがなければ、同じものは入りませんので、例えば、年数を入れて、シート名は、12月(2002),12月(2003)などとなればと、考えました。

・シート全体のコピーの設計は、私はお勧めしません。列幅や印刷設定のコピーでしたら、それは、それぞれ設定すれば済むことです。ただし、印刷設定のすべてをコピーするとなれば、また、別にマクロを置かなくてはなりません。

・印刷設定は、どこまでを希望されているのか分かりません。シート全体のコピーを避けるために、印刷範囲、必要なヘッダー・フッターの一つか二つ、左マージン、上マージン（右と下は、設定しても、計算値で決まるものですから無駄です）できれば、左ヘッダーとか指定したほうがよいです。

行の高さに関しては、現行では考えておりません。

・文字列が長いものを試してみましたが、こちらのマクロでは、そのような問題は発生していませんが、この件は、実際のマクロを試していただくしかありません。

・Microsoft 側では、長い間、結合セルをおいた状態で、その右側のセルにコピーすると、エラーが発生するバグがありましたが、マクロと結合セルは、非常に相性が悪いので、その点は、この先も何かエラーが発生する可能性があります。

私は、まったくコードを読みきれていないままに、安易な回答することはしませんが、この一連のレスを読み直してみました。一応、中途で保存するなりして、問題はクリアしているのが分かりましたので、こちらから、あえて書く必要もなかったかもしれません。

また、こちら側が提供するコードで、次々に出てくる想定外の問題に対処できる自信などもありません。単独のシートとしては、安定した状態なわけですから、あえて、それを、一つの枠組みにいれるようなことは、こちら側からでは難しいかもしれない、とも思っています。

ただ、私なら、こういうように作っていく、というスタイルはわかっていただけるとは思います。

Wendy02 · Answer

こんにちは。もともと、「セルの書式が多すぎるため書式を追加できません」というのは、同じ書式でも、パターン、フォントの種類、フォントの色、罫線、それぞれの組み合わせで、ひとつと数えますから、4,000個というのは、すぐに一杯になってしまいます。それは、本来は、一旦、整理させないといけません。ただ、今回のマクロの問題とは少し違うようです。それは、別問題です。今回のマクロ自身のコード自体に問題があって、それを誘発しているようにしか思えません。ただ、マクロのコードを読むと分からない点がいくつかあります。 >wb.Sheets("12月").Copy After:=mb.Sheets(mb.Sheets.Count) '開いたシートをコピーしてmbの末尾に置くこれをしたら、シート名もコピーされす。しかし、それを繰り返せば、12月(2), 12月(3) となるのですが、それは構わないのでしょうか？なぜ、シートコピーをしているのか良く分かりません。その後で、コピーしているわけですね。その上で、 >wb.Sheets("12月").Range("A1:AO45").Copy 再び、コピーしていますが、なぜでしょう。二重になっていませんか？ >mb.Sheets(mb.Sheets.Count).Unprotect Password:="9" 'パスワード解除コピーされたシートに、プロテクト解除というと、どういうことでしょうか？ >mb.Sheets(mb.Sheets.Count).Paste その前の部分で、このコードでエラーメッセージが出ますね。だから、もともと、プロテクトはされていないように思います。もし、EnableSelection = xlNoSelection　を入れていれば違うかもしれませんが。分からない部分は省きましたが、こちらが書き直してみました。 '------------------------------------------- Sub Consolid03R() 　　''------------------------------------------- 　　''ユーザー設定　　Const sWCARD As String = "\*.xls" 　　Const sSHNAME As String = "12月" 　 ''-------------------------------------------　　　　Dim Mb As Workbook 　　Dim Wb As Workbook 　　Dim mSh As Worksheet 　　Dim shName As String 　　Dim cnt As Long 　　Dim myFDr As String 　　Dim fName As String 　　Dim n As Integer 　　Dim sh As Worksheet 　　Dim c As Variant 　　Dim i As Long 　　　　Application.ScreenUpdating = False 　　Set Mb = ThisWorkbook 　　myFDr = Mb.Path 　　cnt = 1　'シートカウント　　fName = Dir(myFDr & sWCARD) 　　Do 　　　　If fName <> Mb.Name Then 　　　　　　Set mSh = Mb.Worksheets.Add(After:=Mb.Worksheets(Mb.Worksheets.Count)) 　　　　　　With Workbooks.Open(myFDr & "\" & fName) 　　　　　　　　.Worksheets(sSHNAME).Range("A1:AO45").Copy mSh.Range("A1") 　　　　　　　　 shName = .Worksheets(sSHNAME).Name 　　　　　　　　.Close False 　　　　　　End With 　　　　　　　　　　　　On Error Resume Next 　　　　　　'シート名の修正　　　　　　Do 　　　　　　　 mSh.Name = shName 　　　　　　　 If Err.Number > 0 Then 　　　　　　　　　cnt = cnt + 1 　　　　　　　　　mSh.Name = shName & "(" & cnt & ")" 　　　　　　　　　Err.Clear 　　　　　　　 End If 　　　　　　Loop Until Err.Number = 0 　　　　　　On Error GoTo 0 　　　　　　　　　　　　For Each c In mSh.UsedRange.SpecialCells(xlCellTypeFormulas).Cells 　　　　　　　　If InStr(c.Formula, "!") > 0 Then 　　　　　　　　　c.Value = c.Value 　　　　　　　　　DoEvents 　　　　　　　　End If 　　　　　　Next 　　　　　　Application.ScreenUpdating = True 　　　　　　Application.ScreenUpdating = False 　　　　　　n = n + 1 　　　　End If 　　　　fName = Dir 　　Loop While fName <> "" 　　Application.ScreenUpdating = True 　　　　For Each sh In Worksheets 　　　　sh.Tab.ColorIndex = xlColorIndexNone 　　Next sh 　　　　MsgBox UCase(Environ("UserName")) & "さん、" & n & "件のブックをコピーしましました。" _ 　　& vbCrLf & "他シートを参照する式だけは値にしておきましたよ。" _ 　　& vbCrLf & vbCrLf & "", , "（￣ー￣）v " End Sub

avanzato · Answer

#1です。
「セルの書式が多すぎるため書式を追加できません」
このエラーは、罫線や色づけ・フォントサイズなど書式の設定の組が4,000を超えると出るエラーです。
その為ある程度処理が進んだ段階でエラーが発生する感じになります。
過去の質問に回答に繋がると思われる物がありました。
質問番号：3768586

avanzato · Answer

こんにちは。
セルの書式設定が多すぎのエラーはまだ確認していませんが
「クリップボードにおおきな情報があります。この情報を貼り付けられるようにしますか？」は貼り付け処理後に
Application.CutCopyMode = False
を入れることで出なくなります。
また、「「Y」や「N」を都度入力」は
Application.ScreenUpdating = Falseの後に
Application.DisplayAlerts = False
を追加してください。
Application.ScreenUpdatingをTRUEにするときに
Application.DisplayAlertsもTRUEにしてください。

VBAのエラーで、セルの書式が多すぎるため書式を追加できません。

確認が遅くなりました。

こんばんは。

こんにちは。

#1です。

こんにちは。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング