(新)EXCEL VBA コードをズバリで

質問

http://okwave.jp/qa/q6535908.html
http://okwave.jp/qa/q6541470.html

タイトルと質問内容は関係があるようでないような感じです。

質問１、Shapeオブジェクトで真円を描くには？
質問２、Shapeオブジェクトを目的の位置に配置するには？

＜質問１の理由＞

Shapeオブジェクトで0.7mmの円を描かせるとH=0.72、W=0.70の円を描くことがあります。
こういう誤描画は、一度に描く円の数に比例して増加しています。

＜質問２の理由＞

自動化を更に推し進めて配置座標もプログラムで計算・指定。
ですが、どうにも指定した座標（top=320,left=210 etc.)通りに配置されません。

＜質問１の原因と対策＞

２、３個ですと真円を描くが３０個程度になると保証の限りではありません。
ということは、作業量が誤描画の引き金かと推察。

対策１、一つ円を描画したら次の描画まで0.1秒だけプログラムの実行を停止する。
対策２、円を描画しても画面を更新しないように設定する。

＜質問２の原因と対策＞

シートの表示スケールを飼えると描く位置も変化しているように思います。

対策１、シートの表示スケール１００％を基準にする。

※ここら辺りはプログラムの問題ではなく経験知に属するかと思います。
※皆様の１、２への対応要領を教えてもらえれば幸いです。

回答No.1

end-u · ベストアンサー

>0.7mm
0.7cmですか？
単純な描画だけの場合、こちらの環境では再現しません。（Zoom100%）
Sub test()
　　Dim L As Single
　　Dim T As Single
　　Dim W As Single
　　Dim i As Long

　　L = 20
　　T = 20
　　W = 19.84252 '0.7cmに該当するポイント

　　With ActiveSheet.Shapes
　　　　For i = 1 To 100
　　　　　　.AddShape msoShapeOval, L, T * i, W, W
　　　　Next
　　End With
End Sub
１つの対策としては、Duplicateで複製するのもありかもしれません。
Sub test2()
　　Dim s As Shape
　　Dim L As Single
　　Dim T As Single
　　Dim W As Single
　　Dim i As Long

　　L = 40
　　T = 20
　　W = 19.84252
　　With ActiveSheet.Shapes
　　　　Set s = .AddShape(msoShapeOval, L, T, W, W)
　　　　For i = 2 To 100
　　　　　　s.Duplicate.Top = T * i
　　　　Next
　　End With
　　Set s = Nothing
End Sub

質問2について、ver2007ではZoomによって描画位置がずれるという話がありました。
Zoom100%での作成をおすすめします。
また、MicrosoftUpdateで最新パッチをあてれば解消されるかとも思います。

お礼

＜質問１について＞

＞こちらの環境では再現しません。

との回答で、当方との差異を考えてみました。

・円を描画するだけではなく当該のデータを転写していること。

この場合、シートの更新をオフにし描画間隔を０．２秒にすると誤描画は回避可能。
でも、これじゃーチト待機があって難点。
そこで、描画と当該のデータの転写の同時実行を中止、
描画のみ行った後にデータの転写を行って回答者の環境に酷似させてみました。
結果、見事に、誤描画はシートの更新をオフにする限りで皆無となりました。
感謝感激です。

＜質問２について＞

ズーム１００％の場合、全く問題はありません。

以上のように問題は悉く解決しました。

完全自動作画を実現した結果、作業時間は６０分から６分へと大幅に短縮されました。
ただし、現状では、自動化したパターンは半分のみです。
が、残りの半分も、アイデア次第では完全自動作画が可能だと推察します。

昨年は、半年間、Javaのプログラミングに熱中。
その後、プログラミングから遠ざかって一年。
久しぶりに「よっしゃー」の日々でした。
JavaからVBAに感覚を戻すのに少し苦労しました。
が、回答者のお陰で無事に目的を達成することが出来ました。
まあ、これが還暦を過ぎた私の最後のプログラミングかも知れません。
そういう意味では、お付き合いに本当に感謝しています。