ExcelVBA シートの表示倍率が100%以外の状況だとグループ化したシェイプの座標が変化してしまう

Question

前提・実現したいこと

Excel2007のオートシェイプやテキストエリアを使い、地図シンボルと説明の大きさをそろえるマクロを作っています。通常のオートシェイプに対する処理では不具合は無かったのですが、オブジェクトをグループ化したところ、グループ内のシェイプ全体がちょっとずつ位置がズレてしまう現象が起こるようになりました。

テストではグループ化したオブジェクト（オートシェイプとテキストエリアを２セット）、念のため画像（msoPicture）１個で試し、表示倍率が100%以外の場合に同様の現象が発生することがわかりました。

発生している問題・エラーメッセージ

実行前

実行後（１０回実行後）

該当のソースコード

```ここに言語を入力
Public Sub loopGroupedShape()
    Dim sp As Shape
    Dim spg As Shape
    Dim gr As Collection

    Set gr = New Collection
    For Each sp In ActiveSheet.Shapes
        If sp.Type = msoGroup Then
            gr.Add sp
        ElseIf sp.Type = msoPicture Then
            sp.LockAspectRatio = msoFalse
        Else
            sp.LockAspectRatio = msoFalse
            sp.Height = 25
            If sp.Type = msoTextBox Then sp.Width = Len(sp.TextEffect.Text) * 10 Else sp.Width = 25
        End If
    Next

    Do While gr.Count > 0
        For Each spg In gr
            For Each sp In spg.GroupItems
            If sp.Type = msoGroup Then
                    gr.Add sp
            ElseIf sp.Type = msoPicture Then
            Else
                    sp.LockAspectRatio = msoFalse
                    sp.Height = 25
                    If sp.Type = msoTextBox Then sp.Width = Len(sp.TextEffect.Text) * 10 Else sp.Width = 25
                End If
            Next
            gr.Remove 1
        Next
    Loop

End Sub

### 試したこと

・LockAspectRatio を値設定の前後に挿入する
・Debug.Printで現在のHeightやWidthを取得して再挿入する

### 補足情報（FW/ツールのバージョンなど）
MicroSoft Excel 2007
MicroSoft Excel 2010
MicroSoft Excel 2013

Comments

[FromMZ1500]

Excel2010では再現しませんでしたね。

同じような問題で、解決してないかたが海の向こうにいてるような。
https://answers.microsoft.com/en-us/msoffice/forum/msoffice_excel-mso_other-mso_2007/how-do-i-keep-shapes-from-moving-on-their-own-in/df0a4e93-b5ae-460b-9c52-c81ee35af5ab

[Keiichi623]

ご調査ありがとうございます。
ふと思い立って新しいファイルで始めて見たところ、新規のシートでは発生しませんでした。
また、別のバージョンのExcel2013で同ファイルを操作したところ、再度同じ現象が発生しました。
オブジェクトのプロパティを現象が発生しているシートから発生していないシートにコピーするマクロを新規に作成しましたが、シート単位で発生の有無があることがわかりました。

[FromMZ1500]

Excel2013で発生したということは、2007の問題ではないようですね。
ShapeのTop、Left、Height、WidthなどはSingleなので、
なにか処理を行うごとに誤差がまるめられているのかも。
処理の前に値を控えて、処理の後、値を戻してやるという最終手段は、ありますよね。

[Keiichi623]

色々試しているうちに、何故か表示倍率に依拠していることがわかりました。
ちょっと質問を変更して表示倍率を変更して対応してみました。
FromMZ1500さんをベストアンサーに選びたかったのですが、解決済みにしてしまいました。すみません。

[Keiichi623]

実際のところバグの根本的解決には至っていないので悩ましいところです・・・

[FromMZ1500]

お気遣いありがとうございます。
対応策がみつかってなにより。

Answer 1

表示倍率に依拠していることが判明したため、コード中に表示倍率を一時的に100％に変更するコードを作成したところバグの発生を抑制することができました。

Public Sub loopGroupedShape()
Dim sp As Shape
Dim spg As Shape
Dim gr As Collection

Set gr = New Collection
For Each sp In ActiveSheet.Shapes
If sp.Type = msoGroup Then
gr.Add sp
ElseIf sp.Type = msoPicture Then
sp.LockAspectRatio = msoFalse
Else
sp.LockAspectRatio = msoFalse
sp.Height = 25
If sp.Type = msoTextBox Then sp.Width = Len(sp.TextEffect.Text) * 10 Else sp.Width = 25
End If
Next

'追加箇所
    xzoom = ActiveWindow.Zoom
    ActiveWindow.Zoom = 100

Do While gr.Count > 0
For Each spg In gr
For Each sp In spg.GroupItems
If sp.Type = msoGroup Then
gr.Add sp
ElseIf sp.Type = msoPicture Then
Else
sp.LockAspectRatio = msoFalse
sp.Height = 25
If sp.Type = msoTextBox Then sp.Width = Len(sp.TextEffect.Text) * 10 Else sp.Width = 25
End If
Next
gr.Remove 1
Next
Loop

'追加箇所
ActiveWindow.Zoom = xzoom
    

End Sub

根本的な解決には至っていませんが、ひとまず完了とします。
FromMZ1500様、ご対応ありがとうございました。