エクセルマクロを使って図形を等間隔に複数コピー

エクセルマクロを使って次のようなことをしたいのですがいかがでしょうか。過去問を調べていますが、コレという事例に出会えません。何卒よろしくお願いします。

複数の図形がシート上に描かれているとします。
このうちの１つの図形を選択し、その位置を基点として水平方向あるいは垂直方向に指定数だけ等間隔にコピーしたいというものです。

このとき、
（１）「コピーする図形を選んでください」とメッセージを出してマウスで選ぶ。
（２）「コピーする数を入力してください」とメッセージを出して数を入力する。
（３）「配置する間隔を入力してください」とメッセージを出して数値を入力する。
というような対話式にしたいのです。

実際の操作を記録して、それをもとにプログラムしてみても、水平方向にいかず斜めになったりしてわけがわかりません。また（１）の方法が全くわかりません（こんなのはできないのですかね）。

プログラム例を御紹介頂きたくよろしくお願い申し上げます。
※（１）が無理ならば、あらかじめ対象の図形を選んでおいてからプログラムを実行するというのでも結構です。

No.1 ベストアンサー 回答者： Wendy02 回答日時： 2007/11/06 01:40

こんばんは。

過去に、同じような質問は何度も出ていますが、それと、「対話形式」にするのとは、まったく意味が違います。極端に複雑でややこしくなります。

本来は、そのような作成依頼のような内容の質問は、コードを書いても、結局、あまり役には立たないような気がします。実際に、自分の思ったことを、コードで、本当に表現できるのは、なかなか年月が必要です。

今回、私は、個人的な考えがあって、自分自身のために書きましたが、分かるようでしたら、参考にしてみてください。一通りのチェックはしてあるつもりですが、直したほうがよい部分もあるようには思っています。コピー数は、仮の数を考えて、間隔のセル数の2倍の長さが、200列を超えたときに、メッセージではねるようにしました。図形が大きければ、実際は、それよりも、下回ってしまいます。

図形の間隔は、セル幅の数に設定しましたが、5以上は、空きすぎるので、メッセージが出て、受け入れてくれません。

・用意するもの、

UserForm1　標準よりもかなり小さく作ったほうが、やりやすいはずです。
TextBox1
Label1
CommandButton1

それぞれひとつずつです。

シートモジュールに、
コントロールツールのCommandButton1
をひとつ
です。

----------------------------------------------------
シートモジュール
----------------------------------------------------
Private Sub CommandButton1_Click()
　UserForm1.Show False
End Sub

----------------------------------------------------
UserForm モジュール
----------------------------------------------------
'Option Explicit

Dim obj As Object
Dim objNm As String
Dim cnum As Integer
Dim dnum As Integer
Dim crng As Range
Dim StepCnt As Integer
Private Sub CommandButton1_Click()
　　Dim r As Range
　　If obj Is Nothing Then
　　　　Call Proc1
　　　　Exit Sub
　　End If
　　If StepCnt = 1 Then
　　　　Call Proc2
　　　　Exit Sub
　　End If
　　If StepCnt = 2 Then
　　　　Call Proc3
　　　　Exit Sub
　　End If
　　If StepCnt = 3 Then
　　　　Call Proc4
　　'3-4は通し
　　End If
　　If StepCnt = 4 Then
　　　　Call Proc5
　　　　Exit Sub
　　End If
　　If StepCnt = 5 Then '終了
　　　　Unload UserForm1
　　End If
End Sub

Private Sub UserForm_Initialize()
　　Set obj = Nothing
　　cnum = 0
　　StepCnt = 0
　　Set crng = Nothing
　　Range("A1").Select
　　TextBox1.IMEMode = fmIMEModeDisable
　　TextBox1.Enabled = False
　　Label1.Caption = "図形を選んでください。（選択したらボタンをクリック)"
End Sub

Sub Proc1()
　　If VarType(Selection) = vbObject Then
　　　　Set obj = Selection
　　　　If TypeName(obj) = "" Then
　　　　　　MsgBox "選択したものは、図形ではありません。", 48
　　　　　　Exit Sub
　　　　Else
　　　　　　objNm = TypeName(obj)
　　　　　　StepCnt = 1
　　　　　　TextBox1.Enabled = True
　　　　　　Label1.Caption = "図形のコピーする数を入力してください: " & objNm
　　　　End If
　　Else
　　　　MsgBox "図形を選択してください。", 48
　　End If
End Sub
Sub Proc2()
　　'コピー数
　　If IsNumeric(TextBox1.Text) Then
　　　　cnum = CInt(TextBox1.Text)
　　　　If cnum <= 0 Then
　　　　　　MsgBox "数字は、1以上でなくてはなりません。", 48
　　　　Else
　　　　　　StepCnt = 2
　　　　　　TextBox1.Text = ""
　　　　　　Label1.Caption = "設置する間隔をセル数で入力してください。"
　　　　End If
　　Else
　　　　MsgBox "数字を入力してください。", 48
　　End If
End Sub
Sub Proc3()
　　'間隔数
　　If IsNumeric(TextBox1.Text) Then
　　　　dnum = CInt(TextBox1.Text)
　　　　If dnum <= 0 Then
　　　　　　MsgBox "数字は、1以上でなくてはなりません。", 48
　　　　　　dnum = 0
　　　　　　TextBox1.Text = ""
　　　　ElseIf dnum > 4 Then
　　　　　　MsgBox "間隔が空きすぎているようです。", 48
　　　　　　dnum = 0
　　　　　　TextBox1.Text = ""
　　　　 ElseIf dnum * cnum * 2 > 200 Then
　　　　　　MsgBox "間隔とコピー数から無理かもしれません。" & _
　　　　　　"前の段階に戻ります。", 48
　　　　　　Label1.Caption = "図形のコピーする数を入力してください: " & objNm
　　　　　　dnum = 0
　　　　　　cnum = 0
　　　　　　TextBox1.Text = ""
　　　　　　StepCnt = 1
　　　　Else
　　　　　　StepCnt = 3
　　　　　　TextBox1.Text = ""
　　　　　　Label1.Caption = "コピー場所の最初の設定。（ボタンをクリック）"
　　　　End If
　　Else
　　　　MsgBox "数字を入力してください。", 48
　　End If
End Sub
Sub Proc4()
'コピー場所
Dim r As Range
　　 Application.DisplayAlerts = False
　　　On Error Resume Next
　　　Set r = Application.InputBox("コピーの最初の場所を指定してください", Type:=8)
　　　On Error GoTo 0
　　　If r Is Nothing Then Exit Sub
　　　Application.DisplayAlerts = True
　　　Set crng = r
　　　StepCnt = 4
End Sub
Sub Proc5()
　　Dim dif As Integer
　　Dim i As Integer
　　dif = Abs(obj.TopLeftCell.Column - obj.BottomRightCell.Column)
　　If dif < 1 Then dif = 1
　　obj.Copy
　　For i = 1 To cnum
　　　　If i = 1 Then
　　　　　　crng.PasteSpecial
　　　　Else
　　　　　　crng.Offset(, dif * (i - 1) + dnum * (i - 1)).PasteSpecial
　　　　End If
　　Next i
　　Label1.Caption = "終了"
　　CommandButton1.Caption = "終了"
　　TextBox1.Text = ""
　　StepCnt = 5
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
　Set obj = Nothing
　cnum = 0
　dnum = 0
　objNm = ""
　StepCnt = 0
　Set crng = Nothing
End Sub

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

この回答へのお礼

すみません、こんな大変なものとは全く想像もしませんでした。
大変なお時間を取らせてしまいましたよね。申し訳ありません。
正直未熟な下名にとってはすごく難解ですが、それでもひとつひとつ見ていくとわずかながらわかる（と思う）部分もあります。そのエッセンスを理解して自分なりのコードを作成するよう努力したいと思っています。
本当にありがとうございました。感謝申し上げます。

お礼日時：2007/11/06 11:30