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

質問

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

回答No.3

avanzato · ベストアンサー

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

視点を変えて、予めまとめたい複数ブックの書式を統一した書式（デフォルト書式）にしておけばこのエラーは出ないのかもしれません。

参考までに。

お礼

avanzatoさん、先ほど検証してみました。
半分のブックを実行し、一度保存（閉じる）。
再度、残りの半分を実行したところ、無事1つのブックにまとめられました。
確かに手動操作が入りますが、なんとかできそうです。
ありがとうございました。

回答No.5

Wendy02

こんばんは。

まず、いろいろ検討させていただきましたが、現段階では、マクロの設計の仕方そのものを変えないといけないと思います。

おそらく、そのファイルは、それぞれ年数の違うもので、いろんな書式やいろんな作り方が含まれているもので、コピーした後に、すべての書式を、マクロで設定し直さないといけないのですが、見ないで設定するのはむつかしいです。もしも、一定のフォームで作られたものなら、そのようなエラーは発生しないはずです。

せめて、フォントの種類を標準にする、フォントサイズを標準にするというような作業工程を加えないといけないと思います。ある程度の書式設定を、一旦削除して、作りなおさないといけないようです。原因は、きちんと特定できた方がよいと思います。

そうしないと、現状のままでは解決は難しいと思います。

いくつかのポイントに対して、回答とコメントを書かせていただきます。

・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さん、ありがとうございます。
確かに実際のExcelを見ないと難しいですよね。
いろいろご無理を言って申し訳ありませんでした。
ＶＢＡをあまり理解していないまま質問してしまいました。
出来る限り作り直してみます。

回答No.4

Wendy02

こんにちは。

もともと、「セルの書式が多すぎるため書式を追加できません」というのは、同じ書式でも、パターン、フォントの種類、フォントの色、罫線、それぞれの組み合わせで、ひとつと数えますから、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

お礼

Wendy02さん、ありがとうございました。

1つ説明が足りなかったかも知れません。
まず、任意のフォルダを作成し、全てのブックをそのフォルダ内に入れます。そのフォルダ内の全てのブックの特定のシートだけ抽出し、
1つのブックにしようとしています。

>wb.Sheets("12月").Copy After:=mb.Sheets(mb.Sheets.Count) '開いたシートをコピーしてmbの末尾に置く
これをしたら、シート名もコピーされす。しかし、それを繰り返せば、12月(2), 12月(3) となるのですが、それは構わないのでしょうか？なぜ、シートコピーをしているのか良く分かりません。その後で、コピーしているわけですね。

・複数ブックの中のシート名は、1月～12月という月ごとに分けています。（全ブック共通）
例えば12月が必要ならば、12月のシートを複数ブックから抽出し、1つのブックにしています。
従いまして12月（2）,12月（3）となるのは仕方なしとしています。
・シートコピーをしないと書式（列幅、印刷設定、セル結合など全て）をうまくコピーしてこれない（？）からです。

>wb.Sheets("12月").Range("A1:AO45").Copy
再び、コピーしていますが、なぜでしょう。二重になっていませんか？

・再度セル範囲を指定してコピーしているのは、1つのセルの中に255文字以上のセルがあり、シートコピーだと全文字をコピーできないためです。

>mb.Sheets(mb.Sheets.Count).Unprotect Password:="9" 'パスワード解除
コピーされたシートに、プロテクト解除というと、どういうことでしょうか？

・これは以前の名残りです。おっしゃる通り今は無用です。

作成していただいたマクロを実行すると、
For Each c In mSh.UsedRange.SpecialCells(xlCellTypeFormulas).Cells
で止まってしまいます。
また、列幅や印刷設定などがコピーされてません。

ご教示いただけると幸いです。
最後にお礼が大変遅くなり失礼いたしました。

回答No.2

avanzato

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

お礼

avanzatoさん、ありがとうございます。
従来シートごとコピーしていたのですが、セル内に２５５文字以上入力されているセルがあり、２５６文字以降が欠落していました。
そこで、さらにセル範囲を指定し、コピー＆貼付（下記VBA）を追加しました。
wb.Sheets("12月").Range("A1:AO45").Copy
mb.Sheets(mb.Sheets.Count).Range("A1").Select
mb.Sheets(mb.Sheets.Count).Paste
1つ1つのシートはそれほど書式設定が多くはないと思うのですが、これ以上どうしようもないのでしょうか？
ちなみにシートごとコピーしていたときは、書式エラーは出ていませんでした。

回答No.1

avanzato

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

お礼

avanzatoさん、ありがとうございました。
上記2つについては、解決しました。
重ねてありがとうございました。