vba 条件付き書式を一般書式に書き換えたい

VBAは初心者なのですがお力を貸していただきたく・・・
以前こちらで質問してカレンダーを作成しました。
https://oshiete.goo.ne.jp/qa/8978761.html
その際条件付き書式で休日欄を塗りつぶすよう設定したのですが、週によって行数を変えようとしたところ、条件と合わなくなりうまく塗りつぶせません。
最終的には値貼り付けで関数も取り除くので、条件書式で付けた色を一般書式に書き換え、条件式を削除したいです。

１，https://oshiete.goo.ne.jp/qa/2415760.html
こちらの回答を試してみましたがうまく動かず

２，http://www.ka-net.org/office/of56.html
こちらのOfficeクリップボード操作で全て貼り付け（↓）をしてみましたが、できたりできなかったりと安定しません。

素直に１の回答を参考に条件書式でついた色と同じ色を一般書式で設定する方向性で考えていますが、どこを直せばいいのかよくわかりません。。
ちなみに今シートには日付欄（月～金、結合セル）が祝日だった場合ピンクに塗りつぶす条件設定
=MATCH(A4,祝日一覧,0)>0　と、
その下の予定欄をグレーに塗りつぶす条件設定
=COUNTIF(祝日一覧,INDIRECT(ADDRESS(INT(ROW()/4)*4,INT(COLUMN(B1)/2)*2-1)))
のふたつがあります。

長くなってしまいましたが、どなたか教えて頂けると助かります。

２で試したコード
--------------------
Public Sub Sample()
DoActionOfficeClipboard "すべてクリア" ''「すべてクリア」実行
Range("A4:B23").Select
Selection.Copy
DoActionOfficeClipboard "すべて貼り付け" '「すべて貼り付け」実行
DoActionOfficeClipboard "すべてクリア" ''「すべてクリア」実行
Range("C4:D23").Select
Selection.Copy
DoActionOfficeClipboard "すべて貼り付け" '「すべて貼り付け」実行
DoActionOfficeClipboard "すべてクリア" ''「すべてクリア」実行
Range("E4:F23").Select
Selection.Copy
DoActionOfficeClipboard "すべて貼り付け" '「すべて貼り付け」実行
DoActionOfficeClipboard "すべてクリア" ''「すべてクリア」実行
Range("G4:H23").Select
Selection.Copy
DoActionOfficeClipboard "すべて貼り付け" '「すべて貼り付け」実行
DoActionOfficeClipboard "すべてクリア" ''「すべてクリア」実行
Range("I4:J23").Select
Selection.Copy
DoActionOfficeClipboard "すべて貼り付け" '「すべて貼り付け」実行
DoActionOfficeClipboard "すべてクリア" ''「すべてクリア」実行
End Sub
--------------------

質問者からの補足コメント

• tomo04さんありがとうございます！
  一瞬でできました！
  ただ透明セルが白の塗りつぶしになってしまいました。
  ついでといっては失礼ですが、白色セルを塗りつぶしなしにすることはできますか？

  No.1の回答に寄せられた補足コメントです。 補足日時：2015/05/18 21:22

No.1 回答者： tom04 回答日時： 2015/05/18 20:55

こんばんは！

条件付き書式は消して、塗りつぶしだけは残したい！という解釈です。

画像を拝見するとExcel2010のようですので、Displayformatオブジェクトを使ってみました。
安直な方法ですが、一旦Z列以降に選択セルの塗りつぶしの色を退避させておいて
選択範囲の条件付き書式　→　対させている書式（色）で選択セルを塗りつぶし
といった手順にしてみました。
尚、Z列に一旦退避させていますので、Z列以降は使っていないという前提です。
シートモジュールにしてみてください。

Sub Sample1()
Dim c As Range, lastRow As Long, lastCol As Long, cnt As Long
With Selection
lastRow = .Rows.Count
lastCol = .Columns.Count
.Copy Range("Z1")
For Each c In Range("Z1").Resize(lastRow, lastCol)
cnt = cnt + 1
c.Interior.Color = Selection(cnt).DisplayFormat.Interior.Color
Next c
cnt = 0
.FormatConditions.Delete
For Each c In Range("Z1").Resize(lastRow, lastCol)
cnt = cnt + 1
Selection(cnt).Interior.Color = c.Interior.Color
Next c
Range("Z1").Resize(lastRow, lastCol).Clear
End With
End Sub

※　必ず元データを範囲指定してマクロを実行してください。
こんなんではどうでしょうか？m(_ _)m

No.2 ベストアンサー 回答者： tom04 回答日時： 2015/05/18 22:12

No.1です。

＞ただ透明セルが白の塗りつぶしになってしまいました。
ん～～～
前回のコードはZ1以降にコピー＆ペーストしたセルは元データの見た目の書式をそのまま貼り付けていますので
もしかして元データそのものが「白」で塗りつぶされているコトはありませんか？
そうでなければ「白」に塗りつぶされるのは考えにくいのですが・・・
とりあえず、「白」の場合のみ「塗りつぶしなし」にしてみました。
↓のコードに変更してみてください。

Sub Sample2()
Dim c As Range, lastRow As Long, lastCol As Long, cnt As Long
With Selection
lastRow = .Rows.Count
lastCol = .Columns.Count
.Copy Range("Z1")
For Each c In Range("Z1").Resize(lastRow, lastCol)
cnt = cnt + 1
c.Interior.Color = Selection(cnt).DisplayFormat.Interior.Color
Next c
cnt = 0
.FormatConditions.Delete
For Each c In Range("Z1").Resize(lastRow, lastCol)
cnt = cnt + 1
'//▼　ここから修正
'//Z1以降のセルに「白」の塗りつぶしがあれば、「塗りつぶしなし」に
If c.Interior.ColorIndex = 2 Then
Selection(cnt).Interior.ColorIndex = xlNone
Else
Selection(cnt).Interior.Color = c.Interior.Color
End If
'//▲　ここまで
Next c
Range("Z1").Resize(lastRow, lastCol).Clear
End With
End Sub

こんなんではどうですか？m(_ _)m

この回答へのお礼

画像にもあるようにセルの境目の線は見えているので白で塗りつぶしてはいないと思いますが・・・。
ともあれこちらのコードで希望通りに出来ました！
すぐにこんなコードが書けるなんて、私ももっと勉強しないとですね。
何度もありがとうございました！！

お礼日時：2015/05/18 22:34