EXCELでこんなことはできますか？

質問

１）ＥＸＣＥＬで作成した図の情報を集計したい。
　　ＥＸＣＥＬでフロアのレイアウト図を作るとします。
　　その時図は既に別シートに用意されています。図を作成する時には部品（机の絵やキャビネットの絵）のシートよりコピーなどで作図用のシートにコピーし、作成します。
　　作図のシートで部品をいくつつかっているかの集計を行いたいのですが、可能でしょうか？
　　集計用のシートに結果がでるのでもいいですし、作図のシートに集計ボタンをつくり押すと集計結果が作図シートにでるのでもどちらでもよいです。

２）作図の微調整
　　上記で作図した部品を範囲指定をして、ぴたりと隣接させるような機能はありませんか？手で行うと微妙にずれてしまいます。
　　位置あわせは、左端の部品に合わせるとか、指定ができるとありがたいのですが・・
　　　　　　　　宜しくお願いします。

回答No.2

nishi6 · ベストアンサー

各部品には名前をつけます。（当然ついている？）それとシート『集計』を追加します。
シート『集計』に部品個数を名前単位に合計して表示します。ショートカットキーに登録したほうがいいでしょう。ボタンを作るとボタンまで数えてしまうかもしれません。標準モジュールに貼り付けます。

'部品の個数を数える(Ctrl-Z)
Sub ShapesCount()
　　Dim objName() As String '部品の名前
　　Dim objCount() As Integer '部品の個数
　　Dim objKind As Integer '部品の種類(配列のインデックス)
　　Dim cot As Integer '部品カウンタ
　　Dim schKind As Integer '部品配列のインデックス
　　Dim k As Integer 'カウンタ

　　'アクティブシートの全図形を調べで部品ごとに集計する
　　For cot = 1 To ActiveSheet.Shapes.Count
　　　schKind = 0
　　　For k = 1 To objKind
　　　　'部品名配列のどれに該当するか探す
　　　　If ActiveSheet.Shapes(cot).Name = objName(k) Then
　　　　　schKind = k '見つけたインデックス
　　　　　Exit For
　　　　End If
　　　Next

　　　If schKind > 0 Then
　　　　'部品名配列に見つかれば加算する
　　　　objCount(schKind) = objCount(schKind) + 1
　　　Else
　　　　'部品名配列になければ新しく配列を追加する
　　　　objKind = objKind + 1
　　　　ReDim Preserve objName(objKind) '再宣言
　　　　ReDim Preserve objCount(objKind) '再宣言
　　　　objName(objKind) = ActiveSheet.Shapes(cot).Name '部品名をセット
　　　　objCount(objKind) = 1 '個数は1
　　　End If
　　Next

　　With Worksheets("集計") '『集計』シートに書き出す
　　　.Columns("A:B").ClearContents '前回集計を消去
　　　.Range("A1") = "部品" '表題
　　　.Range("B1") = "個数" '表題
　　　For cot = 1 To objKind
　　　　.Range("A" & cot + 1) = objName(cot) '部品名
　　　　.Range("B" & cot + 1) = objCount(cot) '部品の個数
　　　Next
　　End With
End Sub

シート上の図形を揃える機能がないのも不思議ですね。
下は殆どお遊びマクロです。部品を並べたい位置に適当に配置して実行して下さい。
選択した部品の各右位置、横中央、左、下、縦中央、上位置の誤差を計算して一番誤差の少ない箇所を基準に自動的に揃えます。左端を揃えて縦に並べるなら、その感じが分かるようにテキトーに並べてマクロを実行して下さい。シート『集計』のD1セルにセットした値で図形間隔を指定できます。ゼロで密着します。フォームの上にコントロールを作ったときの、コントロールを揃える機能をシート上で行っているつもりです。標準モジュールに貼り付けます。(Excel97、2000で確認済みです)
それにしても長すぎる？いいのかな？

'基準位置を求めて図形を結合する(Ctrl-A)
Sub ShapeAutoSet()
　　Dim pot() As Double '図形の座標
　　Dim srt() As Double 'ソート用配列
　　Dim ord() As Double '図形の並び順
　　Dim sCot As Integer '図形の数
　　Dim s As Integer '図形のカウンタ
　　sCot = Selection.ShapeRange.Count
　　ReDim pot(sCot, 8) '右、横中央、左、下、縦中央、上の順

　　For s = 1 To sCot
　　　With Selection.ShapeRange(s)
　　　　pot(s, 1) = .Left + .Width
　　　　pot(s, 2) = .Left + .Width / 2
　　　　pot(s, 3) = .Left
　　　　pot(s, 4) = .Top + .Height:
　　　　pot(s, 5) = .Top + .Height / 2
　　　　pot(s, 6) = .Top
　　　　pot(s, 7) = .Height
　　　　pot(s, 8) = .Width
　　　End With
　　Next
　　'誤差を求め、最小の要素の位置で揃えるようにする
　　Dim gosa(6) As Double '右、横中央、左、下、縦中央、上を基準にした誤差
　　Dim j As Integer '基準を変える時のカウンタ
　　For j = 1 To 6
　　　For s = 2 To sCot
　　　　gosa(j) = gosa(j) + (pot(s, j) - pot(1, j)) ^ 2
　　　Next
　　Next
　　'最小の誤差は右、横中央、左、下、縦中央、上のどれ？
　　Dim idx As Integer '最小の誤差のインデックス
　　Dim Kijyun As Double '並べる順を決める要素
　　idx = 1
　　For s = 2 To 6
　　　If gosa(s) < gosa(idx) Then
　　　　idx = s: Kijyun = 4: If idx >= 4 Then Kijyun = 1
　　　End If
　　Next
　　'図形の処理順を決める
　　ReDim srt(sCot) 'ソート用配列
　　ReDim ord(sCot) '画面上の並び順
　　Dim wk1 As Double 'ワーク配列(値)
　　Dim wk2 As Integer 'ワーク配列(インデックス)

　　For s = 1 To sCot
　　　ord(s) = s: srt(s) = pot(s, Kijyun)
　　Next
　　　'処理順を決める
　　　s = sCot
　　　While s > 0
　　　　For j = 1 To s
　　　　　If srt(j - 1) > srt(j) Then
　　　　　　wk1 = srt(j - 1): srt(j - 1) = srt(j): srt(j) = wk1
　　　　　　wk2 = ord(j - 1): ord(j - 1) = ord(j): ord(j) = wk2
　　　　　End If
　　　　Next
　　　　s = s - 1
　　　Wend

　　'密接して並べる
　　Dim joinTop As Double '図形を結合する上位置
　　Dim joinLeft As Double '図形を結合する左位置
　　Dim delta As Double '指定した間隔
　　delta = Worksheets("集計").Range("D1")
　　joinTop = pot(ord(1), 6)
　　joinLeft = pot(ord(1), 3)
　　For s = 2 To sCot
　　　Select Case idx
　　　　Case 1, 2, 3 '上から下に並ぶ
　　　　　joinTop = joinTop + pot(ord(s - 1), 7) + delta
　　　　　joinLeft = pot(ord(1), 3) + (pot(ord(1), 8) - pot(ord(s), 8)) * (3 - idx) / 2
　　　　Case 4, 5, 6 '左から右に並ぶ
　　　　　joinTop = pot(ord(1), 6) + (pot(ord(1), 7) - pot(ord(s), 7)) * (6 - idx) / 2
　　　　　joinLeft = joinLeft + pot(ord(s - 1), 8) + delta
　　　End Select
　　　Selection.ShapeRange(ord(s)).Top = joinTop
　　　Selection.ShapeRange(ord(s)).Left = joinLeft
　　Next
End Sub

回答No.1

a-kuma

> 記で作図した部品を範囲指定をして、ぴたりと隣接させるような機能はありませんか？

こちらの方だけ。

「図形描画」のツールバーに「図形の調整」というメニューがあります。ここの
「位置合わせ」をクリックして、「図形」が選択されている状態にしてください。

図形の移動やサイズの変更が、隣接している図形の座標をベースにした動作に
なります。