EXCELでマクロの記録を繰り返して

質問

EXCELでマクロの記録を繰り返して重複した行は分かる範囲でまとめたのですが、もう少しまとめられないかと思っています。

withで、まとめられなくても、順番を入れ替えたらまとまるものとか、逆にまとめようが無いものとか教えて頂けたらと思います。
よろしくお願いします。

With Selection
.Phonetics.Visible = False 'フリガナ表示をオフに
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

With Selection
.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(NOT(ISBLANK($A3)),ISBLANK($L3))"
.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
End With
With Selection.FormatConditions(1).Interior
.Pattern = xlSolid
.PatternColorIndex = 0
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With

With Selection
.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(NOT(ISBLANK($A3)),NOT(ISBLANK($D3)))"
.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.TintAndShade = 0
.PatternTintAndShade = 0
.Color = 5296274
End With

With Selection
.FormatConditions.Add Type:=xlExpression, Formula1:="=AND(NOT(ISBLANK($A3)),ISBLANK($R3))"
.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False

回答No.2

end-u · ベストアンサー

シートを切替える度に設定し直す処理はかなり効率が悪いように思えるのですが、
そこはあまり突っ込まないようにします。
ただ、そのコードが"予約状況"シートであれば、シート保護で対応できるのでは？、という疑問はありますね。

以下、ざっくりコードで
Sub sample()
　　Worksheets("予約状況").Unprotect
　　With Range("A1:A2,B1:B2,C1:C2,D1:D2,E1:E2,F1:F2,G1:G2,H1:H2,I1:I2,J1:J2," & _
　　　　　　"K1:K2,L1:L2,M1:M2,N1:O1,P1:Q1,R1:S1,T1:U1,V1:W1,X1:Y1,Z1:AA1," & _
　　　　　　"AB1:AC1,AD1:AE1,AF1:AG1,AH1:AI1,AJ1:AK1,AL1:AM1,AN1:AO1")
　　　　.HorizontalAlignment = xlDistributed
　　　　.VerticalAlignment = xlCenter
　　　　.WrapText = False
　　　　.Orientation = 0
　　　　.AddIndent = True
　　　　.IndentLevel = 0
　　　　.ShrinkToFit = False
　　　　.ReadingOrder = xlContext
　　　　.MergeCells = True
　　End With

　　Rows.RowHeight = 25
　　Rows("1:2").RowHeight = 17

　　Range("A:F").Columns.AutoFit
　　Range("G:K").ColumnWidth = 8
　　Range("B:C,L:M").ColumnWidth = 21
　　Range("N:AN").ColumnWidth = 23
　　Range("O1,Q1,S1,U1,W1,Y1,AA1,AC1,AE1,AG1,AI1,AK1,AM1,AO1").ColumnWidth = 9
　　Range("AP1").ColumnWidth = 0.2
　　Range("AQ1", Cells(1, Columns.Count)).Columns.Hidden = True

　　With ActiveWindow
　　　　.FreezePanes = False
　　　　.Split = False
　　　　Application.Goto Range("A1"), True
　　　　.SplitColumn = 3
　　　　.SplitRow = 2
　　　　.FreezePanes = True
　　End With

　　'Range("A3").Activate
　　With Range("A3", Cells(Rows.Count, "AO"))
　　　　.Phonetics.Visible = False
　　　　.VerticalAlignment = xlCenter
　　　　.WrapText = False
　　　　.Orientation = 0
　　　　.AddIndent = False
　　　　.ShrinkToFit = False
　　　　.ReadingOrder = xlContext
　　　　.MergeCells = False
　　　　With .FormatConditions
　　　　　　.Delete
　　　　　　.Add(Type:=xlExpression, Formula1:="=AND(NOT(ISBLANK($A3)),ISBLANK($R3))").Interior.ThemeColor = xlThemeColorAccent5
　　　　　　.Add(Type:=xlExpression, Formula1:="=AND(NOT(ISBLANK($A3)),NOT(ISBLANK($D3)))").Interior.Color = 5296274
　　　　　　With .Add(Type:=xlExpression, Formula1:="=AND(NOT(ISBLANK($A3)),ISBLANK($L3))").Interior
　　　　　　　　.Color = 65535
　　　　　　　　.Pattern = xlSolid
　　　　　　End With
　　　　End With
　　End With
End Sub

基本、Selectなしで処理できます。
それに条件付書式を設定する範囲が決まっているなら、前レスでのR1C1形式での処理は必要ありません。
ただ、バージョン2007の場合はコメントアウトしている
'Range("A3").Activate
が必要です。アクティブセルの位置によって数式がずれてしまいます。
2010はその点が改善されているため必要ないです。

『答え合わせ』
別に上記コードが正解ではないです。
自分を含め利用者が理解できてメンテナンスし易く、
目的通り動いてくれるコードならそれで構わないと思いますよ。

お礼

大変わかりやすい回答を何度もありがとうございます。

＞　Range("A:F").Columns.AutoFit

ここですが、該当ブック使用者が意図する・意図しないにかかわらず、必要な幅以下にしてしまった時に、

.WrapText = False　　　　　　　'折り返し解除

になっていないと、狭い幅でAutofitされてしまうので、

＞Range(Columns(1), Columns(mx)).ColumnWidth = 30#

を入れていたのですが、折り返し介助を先にすれば、幅を30にする処理は必要無いのでしょうか。

あと、使用者は複数人居り、使用パソコンも使用ソフト(OS/OFFICE)もバラバラです。バージョン2007もあると思いますが、僕は2010です。

'Range("A3").Activate

は、有効にした方が良いですよね？

'Range("$A$3").Activateとしなくても良いでしょうか。何度も申し訳ありません。

回答No.4

end-u

>ここですが、該当ブック使用者が意図する・意図しないにかかわらず、必要な幅以下にしてしまった時に、
>：
>を入れていたのですが、折り返し介助を先にすれば、幅を30にする処理は必要無いのでしょうか。
そうですね。先に折り返しを解除すれば良いかと思います。
別に設定しても差し支えないとも思いますけれども。
処理する場合は全列ではなくて、A:F列で良いはずですね。
With Range("A:F")
　　.ColumnWidth = 30
　　.Columns.AutoFit
End With
G列以降は固定値と非表示に設定しますから。

>あと、使用者は複数人居り、使用パソコンも使用ソフト(OS/OFFICE)もバラバラです。..
という事であれば Range("A3").Activate は必要です。
または#1のコードで書いたR1C1形式での設定に変更するかですね。

"A3"指定に関しては、数式ではないので相対参照や絶対参照は関係ありません。
$つけてもエラーになりませんが無視されます。

また、ver2003もあるようなら、ThemeColorプロパティは2007で追加されたプロパティなので使えません。
変更する必要があります。

回答No.3

end-u

あ、失礼..
>With Range("A1:A2,B1:B2,C1:C2,D1:D2,E1:E2,F1:F2,G1:G2,H1:H2,I1:I2,J1:J2," & _
>　　　　"K1:K2,L1:L2,M1:M2,N1:O1,P1:Q1,R1:S1,T1:U1,V1:W1,X1:Y1,Z1:AA1," & _
>　　　　"AB1:AC1,AD1:AE1,AF1:AG1,AH1:AI1,AJ1:AK1,AL1:AM1,AN1:AO1")
>　　.HorizontalAlignment = xlDistributed
>　　.VerticalAlignment = xlCenter
>　　.WrapText = False
>　　.Orientation = 0
>　　.AddIndent = True
>　　.IndentLevel = 0
>　　.ShrinkToFit = False
>　　.ReadingOrder = xlContext
>　　.MergeCells = True
>End With
これだとN2:AO2の書式設定が漏れますね。
結合時のエラー対策含めて..

With Range("A1:AO2")
　　.HorizontalAlignment = xlDistributed
　　.VerticalAlignment = xlCenter
　　.WrapText = False
　　.Orientation = 0
　　.AddIndent = True
　　.IndentLevel = 0
　　.ShrinkToFit = False
　　.ReadingOrder = xlContext
End With

Application.DisplayAlerts = False
Range("A1:A2,B1:B2,C1:C2,D1:D2,E1:E2,F1:F2,G1:G2,H1:H2,I1:I2,J1:J2," & _
　　　"K1:K2,L1:L2,M1:M2,N1:O1,P1:Q1,R1:S1,T1:U1,V1:W1,X1:Y1,Z1:AA1," & _
　　　"AB1:AC1,AD1:AE1,AF1:AG1,AH1:AI1,AJ1:AK1,AL1:AM1,AN1:AO1").MergeCells = True
Application.DisplayAlerts = True
：
こうかな。

回答No.1

end-u

Sub sample()
　　Dim ref As Long
　　ref = Application.ReferenceStyle
　　Application.ReferenceStyle = xlR1C1
　　If TypeName(Selection) <> "Range" Then Exit Sub
　　With Selection
　　　　.Phonetics.Visible = False　　 'フリガナ表示をオフに
　　　　.VerticalAlignment = xlCenter　'縦位置中央
　　　　.WrapText = False　　　　　　　'折り返し解除
　　　　.Orientation = 0　　　　　　　 '文字の向き
　　　　.AddIndent = False　　　　　　 'インデント解除
　　　　.ShrinkToFit = False　　　　　 '縮小表示解除
　　　　.ReadingOrder = xlContext　　　'文字読込み順解除（日本語では不要だと思う）
　　　　.MergeCells = False　　　　　　'結合解除
　　　　With .FormatConditions
　　　　　　.Delete　　　　　　　　　　'既設定の条件付書式を削除
　　　　　　.Add(Type:=xlExpression, Formula1:="=AND(NOT(ISBLANK(RC1)),ISBLANK(RC18))").Interior.ThemeColor = xlThemeColorAccent5
　　　　　　.Add(Type:=xlExpression, Formula1:="=AND(NOT(ISBLANK(RC1)),NOT(ISBLANK(RC4)))").Interior.Color = 5296274
　　　　　　.Add(Type:=xlExpression, Formula1:="=AND(NOT(ISBLANK(RC1)),ISBLANK(RC12))").Interior.Color = 65535
　　　　End With
　　End With
　　Application.ReferenceStyle = ref
End Sub

..こんな感じで良いかと思われます。
.WrapTextなどの書式設定の箇所は、既に設定されていたらそれを解除するコードなので、
考慮する必要が無い新規シートなどでは割愛できます。
コードを実行する作業環境に合わせて判断してください。

.FormatConditions.Delete は既に条件付書式が設定されていたらそれを削除するコードです。
既設定を生かして条件を常に追加する場合は .Delete は削除してください。

元コードの.SetFirstPriority は優先順位を１番目にする設定ですので、
最後に追加した条件の優先順位が高くなります。
逆に優先順位が高い順番に.Addすれば設定不要です。

.PatternColorIndex や .TintAndShade などは既定の設定だから不要と判断しましたが、
別途設定する必要がある時は
With .Add(Type:=xlExpression, Formula1:="=AND(NOT(ISBLANK(RC1)),ISBLANK(RC12))").Interior
　　.Color = 65535
　　.Pattern = xlSolid
End With
..のようにしてください。

.StopIfTrue = False「条件を満たす場合は停止」しない設定は、
今回の場合は.Interior（背景色）の設定のみで、実質効果がないので不要だと思われます。

さて。
Dim ref As Long
ref = Application.ReferenceStyle
Application.ReferenceStyle = xlR1C1
：
Application.ReferenceStyle = ref
この箇所がややこしいのですが...

実は『Selection』、つまりコード実行前に選択しているセルに対して設定する場合、
例えば10行目を選択して
.Add(Type:=xlExpression, Formula1:="=AND(NOT(ISBLANK($A3)),ISBLANK($R3))").Interior.ThemeColor = xlThemeColorAccent5
..とやってしまっていいものかどうか、という問題があります。
$A3、$R3、と指定されているという事は列固定で行は相対指定したいという事ですよね。
その場合、数式をR1C1形式で設定するという方法があります。
"=AND(NOT(ISBLANK($A3)),ISBLANK($R3))"
↓
"=AND(NOT(ISBLANK(RC1)),ISBLANK(RC18))"

2003以前のバージョンはこれで自動的にR1C1形式で指定されているんだな、とExcel君が判別してくれていたんですが
2007以降だと A1形式のRC列なのか、行相対でA列固定のR1C1形式なのか判別できません。
そこで
Dim ref As Long
ref = Application.ReferenceStyle
最初に、現在の列表示形式を変数refに控えておいて
Application.ReferenceStyle = xlR1C1
R1C1形式にして条件付書式を設定し、終わったら
Application.ReferenceStyle = ref
控えておいた元の形式に戻す処理をしてます。

もっとも、必ず3行目からセルを選択して実行する、という事が保証されるなら不要な処理ですが。
そのコードだけでは判断できませんので念のため入れました。

If TypeName(Selection) <> "Range" Then Exit Sub
..これも、セルではなく図形やグラフを選択して実行すればエラーになるので、その予防で念のため入れました。

お礼

早速の丁寧な回答と解説ありがとうございます。大変分かり易かったです。また、回答中の注釈も、開発者が変わったとしても分かりやすいものだと思います。本当にありがとうございました。

元コードは Worksheet_Activate()の一部であり、当該コードの前の部分で、

' 選択セル位置の割り出し
row = ActiveCell.row: column = ActiveCell.column

max = Rows.Count: mx = Columns.Count

Worksheets("予約状況").Unprotect

Range("A1:A2,B1:B2,C1:C2,D1:D2,E1:E2,F1:F2,G1:G2,H1:H2,I1:I2,J1:J2,K1:K2,L1:L2,M1:M2,N1:O1,P1:Q1,R1:S1,T1:U1,V1:W1,X1:Y1,Z1:AA1,AB1:AC1,AD1:AE1,AF1:AG1,AH1:AI1,AJ1:AK1,AL1:AM1,AN1:AO1").Select
With Selection
.HorizontalAlignment = xlDistributed
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = True
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With

Range("A1:AO2").Select
With Selection
.HorizontalAlignment = xlDistributed
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = True
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With

'Cells.EntireRow.Hidden = True
'Cells.EntireColumn.Hidden = True

Rows("1:2").RowHeight = 17#
Rows("3:" & max).RowHeight = 25#

Range(Columns(1), Columns(mx)).ColumnWidth = 30#

Columns("AP").ColumnWidth = 0.2

Columns("A:M").EntireColumn.AutoFit
Columns("G:K").ColumnWidth = 8#
Range("B:C,L:M").ColumnWidth = 21#

Columns("N:AO").ColumnWidth = 23#

Range(Columns("AQ"), Columns(mx)).EntireColumn.Hidden = True

ActiveWindow.FreezePanes = False
Range("A1").Activate
Range("A1").Select
Range("D3").Select
ActiveWindow.FreezePanes = True

Range("O:O,Q:Q,S:S,U:U,W:W,Y:Y,AA:AA,AC:AC,AE:AE,AG:AG,AI:AI,AK:AK,AM:AM,AO:AO").ColumnWidth = 9#

Cells.FormatConditions.Delete

'-----------------------------------------------------------------------------------------------------

Range(Cells(3, 1), Cells(max, 41)).Select
' Range("A3:AO1048576").Select

としてあるのです。因みに１～２行目はタイトル行にしてあります。ここも、無駄なコードってありますか？自分でも見てみますので、答え合わせの意味で教えて頂けるとありがたいです。

今回教えて頂いたことを参考にもっと勉強しようと思います。ありがとうございます