ExcelのVBAコードをズバリで・・・。

質問

高齢者活用センターの紹介でExcelで作画をすることになりました。
案件は、国土交通省に提出するマンホールの調査書の作成。

１、マンホールに電気線の穴が幾つあるのか？
２、マンホールに通信線の穴が幾つあるのか？
３、それぞれの穴の径は幾つか？
４、それぞれの穴の使用状況はどのようであるのか？

調査データ

＿Ｎ＿状＿況＿管径
＿０＿管なし＿＿Ａ＝１００
＿１＿未入線＿＿Ｂ＝１１０
＿２＿入線有＿＿Ｃ＝１２０

作図要領

管なし・・・破線の○（中に数字なし）/○の直径＝0.3mm
未入線・・・実線の○（中に数字の１）/○の直径＝0.4mm
入線有・・・実線の●（中に数字の２）/○の直径＝0.5mm

穴の数は２４～５０程。
マンホールの穴の配置に似せて○を配置。
更に、未入線と入線有の場合は○中に数字を書き込む。
加えて、管径情報に基づいて○や●の直径を変更。

これをマンホールの左右側面、前後側面と４カ所描きます。

＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
　２０分で一枚描くために考えた手順
＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊

１、データ入力シートに調査データを入力。
２、それぞれの作図シートに対応する○を破線で配置し数字を書き込む。
３、更新ボタンで入力データに応じて○を仕上げる。
４、同時に作図シートに調査データを転記する。

今、大体、８０分で一文書を仕上げています。
それでは、とても期限内には無理。
そこで、上述のような手順を考えました。
が、私はExcel操作は今日で３日という全くの門外漢。
で、さっぱり、どうやってアイデアを実行に移したらよいのか判りません。
そういうことで質問する次第です。

＜質問：作図シートに配置した図（円）を更新する要領＞

Set myDocument = Worksheets(X)
For Each sh In myDocument.XXXX
　　If sh.Type = XXXXX Then
　　　　If sh.XXX.XXX.XXX = 1 And sh.XXX.XXX.XXX = XXXX Then
　　　　　　sh.XXX.XXX.XXX = XXX
　　　　End If
　　End If
Next

例えば、破線の○を検索して更新するコードは、このようだろうと推測しています。
が、Worksheets(3)などではなくシート名で指定する要領が判りません。
また、XXXXの箇所が全く検討が付きません。
明日中には、この半自動化を達成したいと思っています。

宜しくお願いします。
なお、ExcelのVBAは初めてです

回答No.6

end-u · ベストアンサー

Shape.TextFrameオブジェクトのOrientationプロパティで設定します。
右向きが
sp.TextFrame.Orientation = msoTextOrientationDownward
左向きは
sp.TextFrame.Orientation = msoTextOrientationUpward

msoTextOrientationDownward,msoTextOrientationUpwardは定数で
msoTextOrientationDownwardは 3
msoTextOrientationUpwardは 2
です。

Orientationプロパティの値はLong型ですからtxtMukiはLongで宣言してください。

>マニュアルの読むべき箇所
Excelのバージョンが2007以外だったら「マクロ記録」とヘルプが参考になる、
と書きたいところですが、バージョンによって誤りがあります。
VBEで[ローカルウィンドウ]を使って変数spの中身を展開してプロパティを確認したり、
[オブジェクトブラウザ]で定数を確認したりすると良いです。

#AccessVBAは経験者でいらっしゃいましたよね？
#なので[ローカルウィンドウ]、[オブジェクトブラウザ]等、
#基本的な説明は省いてますけど大丈夫ですよね。

お礼

テストしましたら該当の図のみをそれぞれにキャッチできました。
もはや、完成したも同然です。
これで、明日からの作業は半分の時間となります。
ありがとうございました。

回答No.5

layy

＞PS: しかし、未だ１行も書けずです・・・。

質問が来ないからいいのではなくて、
自分の担当作業にある程度責任を持ってやりましょうよ、ということ。

趣味のレベルならともかく仕事で使うなら
あなた自身も確認が必要です。
回答者がどれだけ確認したかどうかあてにできない時もあります。

１００％を求められるのでは？。

回答No.4

layy

＞国土交通省に提出するマンホールの調査書

今更ですが、
結果は正確さを求められるのでは？。
頼むとしても、実績のある業者に頼めなかったのでしょうか？。

仕様取り間違え、仕様漏れ、とかすでに起こりそうな気配です。

ここでの結果をどうやって正しいと検証するのか、気になります。

提出先から、「どうしてこの値がｘｘなのか？」みたいな質問は来ないのですか？。
そのとき「ネットでプログラム作ってもらったからわかりません・・・」と
いうのは言い訳にならないと思います。

お礼

＞提出先から、「どうしてこの値がｘｘなのか？」みたいな質問は来ないのですか？。

来ないと思います。

データ入力の際に、管径とかは横のセルに換算して表示するようにしています。
また、作画する円の大きさ情報も更にその横のセルに表示。

=IFERROR(VALUE(CutStr("/220/150/100/160/100/50/75/80/30", "/",FIND(F14, "XABCDGHIJK", 1))),"")

Aが管の呼び名で、その径が220ということです。
同じ要領で、作画する円の径も求めます。

これ位の式ですと社員の方も理解できるし必要に応じて修正できるかと思います。

こうして、プログラム中にマジックナンバーを埋め込むことはしません。
ですから、動作する限りではミスはないでしょう。

PS: しかし、未だ１行も書けずです・・・。

何が判らないから書けないのかが判らない現状。
トホホのトホホです。
補足質問するやもしれませんので宜しく！

回答No.3

end-u

失礼。『更新』の意図をちょっと取り違えていました。
既に破線の○があって、"1"や"2"などTextが書いてあり、
それに応じてサイズ変更などの処理をするという事ですね。

Sub try2()
　　Const B As Single = 25 '管径（仮）
　　Const C As Single = 30
　　Dim sp　As Shape　'Loop用
　　Dim tx　As String 'テキスト取得用

　　For Each sp In ActiveSheet.Shapes
　　　　With sp
　　　　　　If .AutoShapeType = msoShapeOval Then
　　　　　　　　tx = ""
　　　　　　　　'バージョンによってエラーが出る対策として
　　　　　　　　'一旦Text取得してみる
　　　　　　　　On Error Resume Next
　　　　　　　　tx = .TextFrame.Characters.Text
　　　　　　　　On Error GoTo 0
　　　　　　　　Select Case tx
　　　　　　　　Case "1"
　　　　　　　　　　.Line.DashStyle = msoLineSolid
　　　　　　　　　　.Width = B
　　　　　　　　　　.Height = B
　　　　　　　　Case "2"
　　　　　　　　　　.Line.DashStyle = msoLineSolid
　　　　　　　　　　.Fill.ForeColor.SchemeColor = vbBlack
　　　　　　　　　　.TextFrame.Characters.Font.Color = vbWhite
　　　　　　　　　　.Width = C
　　　　　　　　　　.Height = C
　　　　　　　　End Select
　　　　　　End If
　　　　End With
　　Next
End Sub

ただ、マクロを使わないでも
最初に３種類のShapeを原型として作っておけば
後は[Ctrl]キーを押しながらShapeをマウスドラッグすれば
複製しながら配置ができますのでそれが手っ取り早いような。

補足

Sub cmdUpdateSokueki_1()
　　Set myDocument = Worksheets("共同調査データ")
　　Dim r　　　　　　　　As Range　　　　' 読み込むRange
　　Dim shapeID　　　　　As Integer　　　' C14,C15,・・・の値
　　Dim kanType　　　　　As Integer　　　' 管の状況
　　Dim kanDiameter　　　As Integer　　　' 管の直径
　　Dim shapeDiameter　　As Integer　　　' 円の直径

　　With myDocument
　　　　For Each r In .Range("C14", .Range("C65536").End(xlUp))
　　　　　　shapeID = r.Value
　　　　　　kanType = r.Offset(, 1).Value
　　　　　　kanDiameter = r.Offset(, 4).Value
　　　　　　shapeDiameter = r.Offset(, 4).Value
　　　　　　updateShapes "特殊部管理台帳", shapeID, kanType, kanDiameter, shapeDiameter
　　　　Next r
　　End With
End Sub

C14,C15・・・に調査した管の番号が入力されています。
管の状況、管の状況、円の直径等は、横のセルに。
それを順次読みとって updateShepes()に渡すことにしました。

Public Sub updateShapes(ByVal docuName As String,
　　　　　　　　　　　　ByVal shapeID As Integer,
　　　　　　　　　　　　ByVal kanType As Integer,
　　　　　　　　　　　　ByVal kanDiameter As Integer,
　　　　　　　　　　　　ByVal shapeDiameter As Integer)
　　Set myDocument = Worksheets(docuName)
　　Dim sp　　　As Shape
　　Dim no　　　As String
　　Dim txtMuki As String　' 右向き文字か左向き文字か

　　For Each sp In myDocument.Shapes
　　　　With sp
　　　　　　If .AutoShapeType = msoShapeOval Then
　　　　　　　　no = .TextFrame.Characters.Text
　　　　　　　　txtMuki = ｘｘｘｘ

　　　　　　End If
　　　　End With
　　Next sp
End Sub

ところで、壁面は４つあり、壁面毎に文字の向きが違います。同一シートに同じ円識別子である番号を持つ○が複数存在することになります。側壁1（cmdUpdateSokueki_1）は、左向きの文字で同じ識別子を持つ円を更新します。

補足質問：

txtMuki = ｘｘｘｘ

この１行が書ければ、多分、目的は達成されます。
できれば、教えていただくか、マニュアルの読むべき箇所をお願いします。

回答No.2

end-u

#続き

その作図シートのＡ１セルから調査データがあるとして
（以下のレイアウト）

　　Ａ　Ｂ
１　Ｎ　管径
２　 0　A
３　 1　B
４　 2　C
５　 0　A
：
つまり、Ａ２から下にデータが並んでいる場合。
Sub try()
　　Const A As Single = 20 '径（仮）
　　Const B As Single = 25
　　Const C As Single = 30
　　Dim sp As Shape
　　Dim r　As Range

　　With ActiveSheet
　　　　For Each r In .Range("A2", .Range("A65536").End(xlUp))
　　　　　　Select Case r.Value
　　　　　　Case 0
　　　　　　　　Set sp = .Shapes("oval0").Duplicate
　　　　　　Case 1
　　　　　　　　Set sp = .Shapes("oval1").Duplicate
　　　　　　Case 2
　　　　　　　　Set sp = .Shapes("oval2").Duplicate
　　　　　　End Select
　　　　　　Select Case r.Offset(, 1).Value
　　　　　　Case "A"
　　　　　　　　sp.Width = A
　　　　　　　　sp.Height = A
　　　　　　Case "B"
　　　　　　　　sp.Width = B
　　　　　　　　sp.Height = B
　　　　　　Case "C"
　　　　　　　　sp.Width = C
　　　　　　　　sp.Height = C
　　　　　　End Select
　　　　　　sp.Name = "ov" & r.Address
　　　　　　sp.Left = r.Offset(, 2).Left
　　　　　　sp.Top = r.Offset(, 2).Top
　　　　Next
　　End With
　　Set sp = Nothing
End Sub

こんな感じでA2セルからA列最終行までLoopしてデータを読み取りながら
原型のShapeを複製します。
A列を基準にr.Offset(, 1)でB列データを読みます。
r.Offset(, 2)でC列に複製Shapeを配置します。
それと同時にA列のアドレスを複製Shapeの名前にします。

これで作成された複製Shapeを手動で配置してはどうですか？
更新の必要があればShapeの名前がアドレスで関連付けられてますから
それが利用できるかと思います。

回答No.1

end-u

>Worksheets(3)などではなくシート名で指定する要領が判りません。
ここは
Set myDocument = Worksheets("Sheet1")
などと、シート名を文字列で指定してあげれば良いです。
ただ、複数シートを処理するなら、対象シートをまずActiveにして、
ActiveSheetに対して処理をしてもいいかもしれません。（『半自動化』なら）

他の要件については今ひとつ条件が不明確なので
ズバリの回答は厳しいです。

ひとつの考え方としては、
まず、作図シートがActiveSheetだとして、原型となるShapeを作成します。

Sub プロト作成()
　　Const k As Single = 20
　　With ActiveSheet
　　　　With .Ovals.Add(200, 0, k, k)
　　　　　　.Name = "oval0"
　　　　　　.Placement = xlMove
　　　　　　.Border.Color = vbBlack
　　　　　　.Border.LineStyle = msoLineDash
　　　　　　.Interior.Color = vbWhite
　　　　End With
　　　　With .Ovals.Add(300, 0, k, k)
　　　　　　.Name = "oval1"
　　　　　　.Placement = xlMove
　　　　　　.Text = "1"
　　　　　　.Font.Size = 10
　　　　　　.HorizontalAlignment = xlCenter
　　　　　　.VerticalAlignment = xlCenter
　　　　　　.Border.Color = vbBlack
　　　　　　.Interior.Color = vbWhite
　　　　　　.Font.Color = vbBlack
　　　　End With
　　　　With .Ovals.Add(400, 0, k, k)
　　　　　　.Name = "oval2"
　　　　　　.Placement = xlMove
　　　　　　.Text = "2"
　　　　　　.Font.Size = 10
　　　　　　.HorizontalAlignment = xlCenter
　　　　　　.VerticalAlignment = xlCenter
　　　　　　.Border.Color = vbBlack
　　　　　　.Interior.Color = vbBlack
　　　　　　.Font.Color = vbWhite
　　　　End With
　　End With
End Sub

それぞれ"oval0","oval1","oval2"と名前をつけます。

お礼

早速の回答ありがとうございます。

マンホールの電気と通信の穴の数と配置の型は１００程度あるようです。
型番号１～型番号９０などの図面があります。
その図面を元に手書きで書き写し、かつ、写真を撮るとのこと。
作業者の手書きと写真を基に穴の現状を再現するのが作画の目的。

ところで、私は、あくまでも高齢者のセンターから派遣された臨時雇いです。
ですから、正社員が作り上げたやり方を踏襲しつつの半自動化。

１、データ入力シートを追加する。
２、穴の配置に応じた破線の○を配置しグループ化した図の集合シートを追加する。

この２つだけが臨時の私ができる改善です。

作業手順

１、集合シートより該当する図を選んで従来のシートにコピペ。
２、入力データに基づいて○を加工。
３、入力データに基づいて各穴の調査データを作成・完成する。

改善１、加工する図の原型が用意されることになる。
改善２、各○の加工が入力データで自動化されるのでミスが防げる。
改善３、各○の調査データもわざわざ入力しないでよくなる。

と、補足しておきます。

本日、午後２時より作業を開始します。

退職して２年。
今更、ＥｘｃｅｌのＶＢＡを書くことになろうとは思ってもいませんでした。
でも、工事用のプレハブで必死に作業している作業員の苦労を軽減してやりたいのです。
最低賃金に毛の生えたような報酬でも退職者にはありがたいものです。

さて、ＥｘｃｅｌのＶＢＡなんてＥｘｃｅｌ９５のそれしか知りません。
ですから、実際に作業に入れば多分判らないことだらけ。
補足の説明を求めなければならないかも知れません。
そういう事情で、先ずはお礼はここまでとさせていただきます。
お礼を書いていない回答も目を皿のようにして読むつもりです。

本当に、早速の回答ありがとうございました。