■（Shapes）SelectionのLoopについて

きっかけは
現在、エクセルで、選択したグラフの大きさや縦横軸を統一するマクロを作成... - 教えて！goo
このスレッドだったんですが、ちょっと追加検証してみました。
（下記コードの内容）
新規シートにShapeを３コ追加します。
順番に名前をRect1、Rect2、Rect3、とつけます。
Rect2、Rect1、Rect3、の順番で選択して、選択した順番を保持するかどうかテストしてみます。

Sub test1()
　　Dim i As Long
　　Dim s As Object

　　With Sheets.Add
　　　　For i = 1 To 3
　　　　　　.Shapes.AddShape(msoShapeRectangle, 100, 100 * i, 100, 50).Name = "Rect" & i
　　　　Next

　　　　.Shapes("Rect2").Select
　　　　.Shapes("Rect1").Select False
　　　　.Shapes("Rect3").Select False

　　　　Debug.Print vbLf & "For To 1回目"
　　　　For i = 1 To Selection.Count
　　　　　　Debug.Print Selection.Item(i).Name
　　　　Next

　　　　Debug.Print vbLf & "For To 2回目"
　　　　For i = 1 To Selection.Count
　　　　　　Debug.Print Selection.Item(i).Name
　　　　Next

　　　　.Shapes("Rect2").Select
　　　　.Shapes("Rect1").Select False
　　　　.Shapes("Rect3").Select False

　　　　Debug.Print vbLf & "For Each 1回目"
　　　　For Each s In Selection
　　　　　　Debug.Print s.Name
　　　　Next

　　　　Debug.Print vbLf & "For Each 2回目"
　　　　For Each s In Selection
　　　　　　Debug.Print s.Name
　　　　Next

　　End With
End Sub

そのままSelectionをLoopした場合、

【Excel2003 test1】
For To 1回目
Rect2
Rect2
Rect3

For To 2回目
Rect1
Rect2
Rect3

For Each 1回目
Rect2
Rect1
Rect3

For Each 2回目
Rect1
Rect2
Rect3

【Excel2007 test1】
For To 1回目
Rect1
Rect2
Rect3

For To 2回目
Rect1
Rect2
Rect3

For Each 1回目
Rect2
Rect1
Rect3

For Each 2回目
Rect2
Rect1
Rect3

こんな結果です。
期待するのはRect2、Rect1、Rect3、なんですが、どうにも不思議な結果です...

Selectionを一旦変数に受けたらどうなるか。

Sub test2()
　　Dim i　As Long
　　Dim s　As Object
　　Dim ss As Object

　　With Sheets.Add
　　　　For i = 1 To 3
　　　　　　.Shapes.AddShape(msoShapeRectangle, 100, 100 * i, 100, 50).Name = "Rect" & i
　　　　Next

　　　　.Shapes("Rect2").Select
　　　　.Shapes("Rect1").Select False
　　　　.Shapes("Rect3").Select False
　　　　Set ss = Selection

　　　　Debug.Print vbLf & "For To 1回目"
　　　　For i = 1 To ss.Count
　　　　　　Debug.Print ss.Item(i).Name
　　　　Next

　　　　Debug.Print vbLf & "For To 2回目"
　　　　For i = 1 To ss.Count
　　　　　　Debug.Print ss.Item(i).Name
　　　　Next

　　　　.Shapes("Rect2").Select
　　　　.Shapes("Rect1").Select False
　　　　.Shapes("Rect3").Select False
　　　　Set ss = Selection

　　　　Debug.Print vbLf & "For Each 1回目"
　　　　For Each s In ss
　　　　　　Debug.Print s.Name
　　　　Next

　　　　Debug.Print vbLf & "For Each 2回目"
　　　　For Each s In ss
　　　　　　Debug.Print s.Name
　　　　Next

　　End With
　　Set ss = Nothing
End Sub

【Excel2003 test2】
For To 1回目
Rect2
Rect1
Rect3

For To 2回目
Rect2
Rect1
Rect3

For Each 1回目
Rect2
Rect1
Rect3

For Each 2回目
Rect2
Rect1
Rect3

【Excel2007 test2】
For To 1回目
Rect1
Rect2
Rect3

For To 2回目
Rect1
Rect2
Rect3

For Each 1回目
Rect2
Rect1
Rect3

For Each 2回目
Rect2
Rect1
Rect3

Excel2003では期待通りに取れてるようですが、2007とはやはりバージョンによる違いが出てます。
2007はtest1とtest2の結果が同じなので、まあ、首尾一貫してると言えば言えるのかも。
追加テストでtest2直後、選択した状態でもう一度下記For Eachでのテストを実行すると

Sub test3()
　　Dim s　As Object
　　Dim ss As Object

　　Set ss = Selection
　　For Each s In ss
　　　　Debug.Print s.Name
　　Next
End Sub

【Excel2003 test3】
Rect1
Rect2
Rect3

【Excel2007 test3】
Rect2
Rect1
Rect3

って結果です。
あまりニーズがない案件でしょうけど、何かの時に参考に...
...ならないか X(

re2:xl2007：ModifyAppliesToRange でTypeが変わる

■xl2007：ModifyAppliesToRangeメソッド にコメントいただいた内容についての返信記事です。
コメントには文字数制限があるようで、そちらに書ききれなかったので別記事にしました。

>複数の条件付き書式が設定されていて
>その中に「数式」があった場合、
>ModifyAppliesToRangeを実行後、Typeが「セルの値」に変わってしまいました。
>対処策はあるのでしょうか？

どうも、Typeが変わるわけでは無いようです？

ちょっと実験しました。
元記事の Macro1 を少し変更して、条件3に Type:=xlExpression を設定してみます。

Sub 準備()
　　With Sheets.Add
　　　　'A1:C1に条件1
　　　　With .Range("A1:C1").FormatConditions
　　　　　　.Delete
　　　　　　With .Add(Type:=xlCellValue, _
　　　　　　　　　　　Operator:=xlEqual, _
　　　　　　　　　　　Formula1:="1")
　　　　　　　　.Interior.ColorIndex = 35
　　　　　　End With
　　　　End With
　　　　'B1:C1に条件2
　　　　With .Range("B1:C1").FormatConditions
　　　　　　With .Add(Type:=xlCellValue, _
　　　　　　　　　　　Operator:=xlEqual, _
　　　　　　　　　　　Formula1:="2")
　　　　　　　　.Interior.ColorIndex = 36
　　　　　　End With
　　　　End With
　　　　'C1に条件3
　　　　With .Range("C1").FormatConditions
　　　　　　With .Add(Type:=xlExpression, _
　　　　　　　　　　　Formula1:="=RC<4")
　　　　　　　　.Interior.ColorIndex = 37
　　　　　　End With
　　　　End With
　　　　.Range("A1:C1").Value = [{1,2,3}]
　　End With
End Sub

できたシートをActiveにして、ダイレクトにModifyAppliesToRangeメソッドで[適用先]セル範囲を変更します。

Sub test()
　　Dim fc As FormatCondition
　　Dim i　As Long

　　With ActiveSheet.Range("C1")
　　　　For Each fc In .FormatConditions
　　　　　　i = i + 1
　　　　　　Debug.Print "before" & i, fc.Type, _
　　　　　　　　　　　　　　　　　　　fc.Formula1, _
　　　　　　　　　　　　　　　　　　　fc.AppliesTo.Address
　　　　　　fc.ModifyAppliesToRange .Item(1)
　　　　　　'ModifyAppliesToRange直後のAppliesToプロパティはエラー
　　　　　　Debug.Print "after " & i, fc.Type, _
　　　　　　　　　　　　　　　　　　　fc.Formula1 ', _
　　　　　　　　　　　　　　　　　　　fc.AppliesTo.Address
　　　　Next
　　　　i = 0
　　　　Stop
　　　　Debug.Print
　　　　For Each fc In .FormatConditions
　　　　　　i = i + 1
　　　　　　Debug.Print "replace" & i, fc.Type, _
　　　　　　　　　　　　　　　　　　　 fc.Formula1, _
　　　　　　　　　　　　　　　　　　　 fc.AppliesTo.Address
　　　　Next
　　End With
End Sub

（結果）

before1　　　　1　　　　　　=1　　　　　　$A$1:$C$1
after 1　　　　1　　　　　　=2
before2　　　　1　　　　　　=2　　　　　　$B$1:$C$1
after 2　　　　2　　　　　　=C1<4
before3　　　　2　　　　　　=C1<4　　　　 $C$1
after 3　　　　2　　　　　　=C1<4

replace1　　　 1　　　　　　=1　　　　　　$C$1
replace2　　　 1　　　　　　=2　　　　　　$C$1
replace3　　　 2　　　　　　=C1<4　　　　 $C$1

FormatConditionsをLoopしてModifyするんですけど、
ModifyAppliesToRange直後はFormatConditionsのItemを正しく取得できてないようですね。
#リセットされたような感じで次のfcを見に行ってる？
コメントしてるように、AppliesToプロパティを取得しようとするとエラーになりますし。
For EachではなくFor..ToでインデックスをLoopしても同じ。
どうにも挙動不審です。

>Typeが「セルの値」に変わってしまいました。
Loopし直して再取得してみてください。

作業用にコピーしてた場合はインデックスも逆転してるので気をつけてください。
■xl2007：SetFirstPriorityメソッド

■ワークシート上のPictureの倍率を取得する（後編

さて、と。
勘違いの前編は捨て記事扱いでいいですけど、その Sub test2 を2007で実行するとエラーです。
>With Selection.Duplicate.ShapeRange
がイケてません。

Pictureに対して
With Selection.Duplicate
　　MsgBox .Name
End With
や
Dim pic As Picture
Set pic = Selection.Duplicate
ってやると2003は通りますが2007はダメです。
Duplicateが失敗しているわけではなく、複製はできています。
複製と同時にObjectとして扱えないような感じです。

しつこくチェックしてみると
Dim x
With ActiveSheet
　　With .Pictures
　　　　Set x = .Item(.Count).Duplicate 'A
　　　　MsgBox TypeName(x)
　　End With
　　With .Shapes
　　　　Set x = .Item(.Count).Duplicate 'B
　　　　MsgBox TypeName(x)
　　End With
End With
Set x = Nothing

2003では
A　Picture
B　Shape

2007では
A　エラー
B　Shape

何の事はない、Shapeに対してDuplicateすれば良いだけだったり？
つまり
>With Selection.Duplicate.ShapeRange
With Selection.ShapeRange.Duplicate

Sub test3() 'Pictureを選択して実行
　　Dim x As Single
　　Dim y As Single

　　If TypeName(Selection) = "Picture" Then
　　　　With Selection.ShapeRange.Duplicate
　　　　　　With .PictureFormat
　　　　　　　　.CropTop = 0#
　　　　　　　　.CropLeft = 0#
　　　　　　　　.CropRight = 0#
　　　　　　　　.CropBottom = 0#
　　　　　　End With
　　　　　　x = .Width
　　　　　　y = .Height
　　　　　　.LockAspectRatio = msoFalse
　　　　　　.ScaleWidth 1, msoTrue
　　　　　　.ScaleHeight 1, msoTrue
　　　　　　x = x / .Width
　　　　　　y = y / .Height
　　　　　　.Delete
　　　　End With
　　　　MsgBox "x:= " & x & vbLf & "y:= " & y
　　End If
End Sub

以上、余談でした（ぇ


で、本題ですが :D
一見上手くいきそうな Sub test も2007ではイケてません。
上辺、左辺をトリミングした画像を Top = 0 , Left = 0 の位置で実行すると
>.CropTop = 0#
>.CropLeft = 0#
この時、画面外にハミ出す（？）為か、トリミング解除後のWidthとHeightが正しく取得できないようです。

（Excel2007：Sub test 実行前）


（Excel2007：Sub test 実行後）


一応、2007では http://oshiete.goo.ne.jp/qa/6074786.html の回答コードで、トリミングの場合でも取得できてます。
でもトリミング画像に対するScaleWidth｜Heightメソッドの挙動が、2007から変わってたようです。
なので2003の場合は対応できていませんでした。
トリミング画像に対して

With Selection.ShapeRange
　　.ScaleWidth 1, msoTrue
　　.ScaleHeight 1, msoTrue
End With

ScaleWidth｜Heightメソッドを実行した場合、
2003ではトリミング後のWidth,Heightを元サイズのWidth,Heightに戻します。
2007では元サイズのWidth,Heightからトリミング値を考慮した値になります。

（2003,2007比較）


結論としては、バージョンによる分岐処理が必要...という事になるのでしょうか。

Option Explicit
'---------------------------------------------------------------------
Sub try() 'Pictureを選択して実行
　　Dim ret

　　If TypeName(Selection) = "Picture" Then
　　　　ret = fGetPicScale(Selection)
　　　　If IsArray(ret) Then
　　　　　　MsgBox "x:= " & ret(0) & vbLf & "y:= " & ret(1)
　　　　End If
　　End If
End Sub
'---------------------------------------------------------------------
Function fGetPicScale(ByRef pic As Picture)
　　Dim x　As Single
　　Dim y　As Single
　　Dim T　As Single
　　Dim L　As Single
　　Dim W　As Single
　　Dim H　As Single
　　Dim LC As Long

　　On Error GoTo errExit
　　With pic.ShapeRange
　　　　T = .Top
　　　　L = .Left
　　　　W = .Width
　　　　H = .Height
　　　　LC = .LockAspectRatio
　　　　'画像位置によっては元サイズに戻しきれない場合の対策
　　　　.Top = 0
　　　　.Left = 0
　　　　.LockAspectRatio = msoFalse
　　　　.ScaleWidth 1, msoTrue, msoScaleFromTopLeft
　　　　.ScaleHeight 1, msoTrue, msoScaleFromTopLeft
　　　　'Ver2003以前のみトリミング値を考慮する
　　　　If CLng(Application.Version) < 12 Then
　　　　　　With .PictureFormat
　　　　　　　　x = .CropLeft + .CropRight
　　　　　　　　y = .CropTop + .CropBottom
　　　　　　End With
　　　　End If
　　　　x = W / (.Width - x)
　　　　y = H / (.Height - y)
　　　　.Top = T
　　　　.Left = L
　　　　.Width = W
　　　　.Height = H
　　　　.LockAspectRatio = LC
　　End With
　　fGetPicScale = Array(x, y)
errExit:
End Function

■ワークシート上のPictureの倍率を取得する（前編

#〆後にレス追加するのも最近億劫になってしまって...

エクセルVBAで、画像の倍率を知るには、どのようにすればいいのでしょう... - 教えて！goo

んぁ、トリミングしてた場合ですね。
基本、考え方は同じで

Option Explicit
'---------------------------------------------------------------------
Sub test() 'Pictureを選択して実行
　　Dim ret

　　If TypeName(Selection) = "Picture" Then
　　　　ret = fGetPicScale(Selection)
　　　　If IsArray(ret) Then
　　　　　　MsgBox "x:= " & ret(0) & vbLf & "y:= " & ret(1)
　　　　End If
　　End If
End Sub
'---------------------------------------------------------------------
Function fGetPicScale(ByRef pic As Picture)
　　Dim xy(0 To 1)　 As Single
　　Dim crop(0 To 3) As Single
　　Dim W　As Single
　　Dim H　As Single
　　Dim LC As Long

　　On Error GoTo errExit
　　With pic.ShapeRange
　　　　With .PictureFormat
　　　　　　crop(0) = .CropTop
　　　　　　crop(1) = .CropLeft
　　　　　　crop(2) = .CropRight
　　　　　　crop(3) = .CropBottom
　　　　　　.CropTop = 0#
　　　　　　.CropLeft = 0#
　　　　　　.CropRight = 0#
　　　　　　.CropBottom = 0#
　　　　End With
　　　　W = .Width
　　　　H = .Height
　　　　LC = .LockAspectRatio
　　　　.LockAspectRatio = msoFalse
　　　　.ScaleWidth 1, msoTrue
　　　　.ScaleHeight 1, msoTrue
　　　　xy(0) = W / .Width
　　　　xy(1) = H / .Height
　　　　.Width = W
　　　　.Height = H
　　　　.LockAspectRatio = LC
　　　　With .PictureFormat
　　　　　　.CropTop = crop(0)
　　　　　　.CropLeft = crop(1)
　　　　　　.CropRight = crop(2)
　　　　　　.CropBottom = crop(3)
　　　　End With
　　End With
　　fGetPicScale = xy
errExit:
End Function

ワークシート上に挿入した画像ファイルの、原型サイズと比較した時の倍率を得るコード。
Pictureを選択して、Selectionに対して処理するようにしてます。

現状画像の退避情報として
・PictureFormatプロパティのトリミングポイント（Top,Left,Right,Bottom）
・サイズ（Width,Height）
・LockAspectRatioプロパティ
以上を記憶します。

ScaleWidthメソッド、ScaleHeightメソッドを使って一旦原型サイズにし、
倍率を計算して取得した後、退避情報を元に処理前に戻します。

（実行例）


Duplicateメソッドで複製して最後に削除すれば、戻す必要がないので簡易的なコードでいけます。

Sub test2() 'Pictureを選択して実行
　　Dim x As Single
　　Dim y As Single

　　If TypeName(Selection) = "Picture" Then
　　　　With Selection.Duplicate.ShapeRange
　　　　　　With .PictureFormat
　　　　　　　　.CropTop = 0#
　　　　　　　　.CropLeft = 0#
　　　　　　　　.CropRight = 0#
　　　　　　　　.CropBottom = 0#
　　　　　　End With
　　　　　　x = .Width
　　　　　　y = .Height
　　　　　　.LockAspectRatio = msoFalse
　　　　　　.ScaleWidth 1, msoTrue
　　　　　　.ScaleHeight 1, msoTrue
　　　　　　x = x / .Width
　　　　　　y = y / .Height
　　　　　　.Delete
　　　　End With
　　　　MsgBox "x:= " & x & vbLf & "y:= " & y
　　End If
End Sub

...と、ここまで書いて、そう言えば2007ではDuplicateメソッドの振る舞いが違ってたなぁと思い出してチェックしてみたら...
全然ダメダメ君でありました...orz

#後編につづく？

■xl2007：SetFirstPriorityメソッド

微妙に昨日の続きみたいなものだったりします...

2007での条件付き書式範囲のコピーには、バグが潜んでるみたい。
『コピーして Excel 2007 で [セルを貼り付けると、条件付き書式ルールが重複してください。』
http://support.microsoft.com/kb/973823/ja
これはパッチが当たって直ったようですが。

昨日の例のように、各条件が独立して関連がない時はともかくとして、条件別に優先順位が絡むとちょっとマズいかも、という話です。
昨日と似たような例示で、

Sub Macro1()
　　With Sheets.Add
　　　　'A1:C1に条件1
　　　　With .Range("A1:C1").FormatConditions
　　　　　　.Delete
　　　　　　With .Add(Type:=xlExpression, Formula1:="=RC>2")
　　　　　　　　.Interior.ColorIndex = 35
　　　　　　End With
　　　　End With
　　　　'B1:C1に条件2
　　　　With .Range("B1:C1").FormatConditions
　　　　　　With .Add(Type:=xlExpression, Formula1:="=RC>1")
　　　　　　　　.Interior.ColorIndex = 36
　　　　　　End With
　　　　End With
　　　　'C1に条件3
　　　　With .Range("C1")
　　　　　　With .FormatConditions
　　　　　　　　With .Add(Type:=xlExpression, Formula1:="=RC>0")
　　　　　　　　　　.Interior.ColorIndex = 37
　　　　　　　　End With
　　　　　　End With
　　　　　　.Value = 3
　　　　End With
　　End With
End Sub

Macro1 実行後。




こんな感じで、やはり[適用先]のセル範囲が条件ごとに違う場合で、条件1→条件3の優先順位で設定されているとします。
この時、

Sub test()
　　Range("C1").Copy Range("C2")
End Sub

などとしてしまうと、




優先順位がひっくり返ってしまいます。
なぜかFillDown、FillRightメソッドだと大丈夫なんですが。


昨日の例で、シートまるごとコピーする場合でも同様です。
単純なFormula1取得が目的だったら昨日のコードでもいいんですけど、優先順位も考慮したいなら、SetFirstPriorityメソッドを使って設定し直したほうが良いかもしれません。

もっとも、あまり深く検証したわけではないので、[適用先]範囲が条件ごとに違う場合の全てのケースで発生するかどうかは不明です。

Sub test1改2()
　　Dim r　 As Range
　　Dim i　 As Long
　　Dim ret As String

　　ActiveSheet.Copy
　　With ActiveWorkbook
　　　　.Activate
　　　　Set r = ActiveSheet.Range("C1")
　　　　With r.FormatConditions
　　　　　　For i = 2 To .Count
　　　　　　　　.Item(i).SetFirstPriority '■
　　　　　　Next
　　　　　　For i = 1 To .Count
　　　　　　　　.Item(i).ModifyAppliesToRange r
　　　　　　Next
　　　　　　ret = fcTest(r)
　　　　End With
　　　　'.Close False
　　End With
　　Set r = Nothing
　　MsgBox ret
End Sub
'---------------------------------------------------------------------
Function fcTest(ByRef r As Range) As String
　　Dim n As Long
　　Dim i As Long

　　With r.FormatConditions
　　　　n = .Count
　　　　ReDim ret(1 To n) As String
　　　　For i = 1 To n
　　　　　　ret(i) = .Item(i).Formula1
　　　　Next
　　End With
　　fcTest = Join(ret, vbLf)
　　Erase ret
End Function

test1改2 実行後。






#2010.08.16 追記）
#>もっとも、あまり深く検証したわけではないので、...
#なんてヨボー線はってやがる。
#懺悔編あり:D