[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『工程表の自動オートシェイプ』(!)
工程表を作成しています。
A列縦に項目
B列は内容
C列に開始日
D列に終了日
E列から2015/5/1 2015/5/2・・・・
A9から始まっていますが
範囲は増えたりするので定まっていません。
開始日と終了日を条件に
E列からの日付にオートシェイプをVBAで引きたいです
開始日が5/1で終了日が5/3なら5/1〜5/3に→を引きたいのですが
色々なサイトのコードを試しましたが途中で止まったりとうまくいきません。
どなたかわかる方お願い致します。
< 使用 Excel:Excel2010、使用 OS:Windows8 >
Sub test() Const iC = 5 Dim S As Shape Dim i As Long Dim iMax As Long Dim ih As Long Dim iw As Long Dim ix As Long Dim iy As Long Dim iSt As Long Dim iEd As Long
For Each S In Shapes If (S.Name Like "Right Arrow*") Then S.Delete End If Next
ih = Range("A9").Height / 2 iMax = Cells(Rows.Count, "C").End(xlUp).Row
For i = 9 To iMax If Cells(i, "D").Value <> "" Then iSt = Cells(i, "C").Value - Cells(8, iC).Value + iC iEd = Cells(i, "D").Value - Cells(8, iC).Value + iC If iSt < iC Then iSt = iC End If If iEd < iC - 1 Then iEd = iC - 1 End If If (iSt < Columns.Count) And (iEd < Columns.Count) Then ix = Cells(i, iSt).Left iy = Cells(i, iSt).Top + ih / 2 iw = Cells(i, iEd + 1).Left - ix If 0 < iw Then ActiveSheet.Shapes.AddShape(msoShapeRightArrow, ix, iy - 1, iw, ih).Select Selection.ShapeRange.Line.Weight = 0.75 Selection.ShapeRange.Fill.ForeColor.SchemeColor = 48 End If End If End If Next i End Sub (???) 2015/05/12(火) 14:34
A B C D E F G ・・・ AI 8 項目 内容 開始日 終了日 5/1 5/2 5/3 5/31 9 a b 5/8 5/10 10 c d 5/11 5/20
http://www.moug.net/tech/exvba/0120005.html
のコードを少し変えて
Sub Sample()
Dim rngStart As Range, rngEnd As Range Dim BX As Single, BY As Single, EX As Single, EY As Single Dim LastRow As Long, i As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 9 To LastRow Set rngStart = Range("E8:AI8").Find(what:=Range("C" & i), lookat:=xlWhole).Offset(i - 8, 0) Set rngEnd = Range("E8:AI8").Find(what:=Range("D" & i), lookat:=xlWhole).Offset(i - 8, 0)
BX = rngStart.Left BY = rngStart.Top EX = rngEnd.Left + rngEnd.Width EY = rngEnd.Top
With ActiveSheet.Shapes.AddLine(BX, BY + 8, EX, EY + 8).Line .ForeColor.RGB = vbRed .Weight = 1.5 .EndArrowheadStyle = msoArrowheadTriangle End With Next
End Sub (se_9) 2015/05/12(火) 14:58
の部分でオブジェクト変数またはWithブロックが設定されていません。
という実行エラー91が出て止まってしまうのですが
なぜかおわかりになったりしますでしょうか・・・???
(!) 2015/05/13(水) 09:38
日付が入っているセルの位置(私が想定しているのはE8セルからAI8セル)が合っているか 日付がシリアル値で入力されているか確かめてみてください。 (se_9) 2015/05/13(水) 09:55
もしかしてE列からAI列の日付って数式になってますか? (se_9) 2015/05/13(水) 13:02
Set rngStart = Range("E8:AI8").Find(what:=Range("C" & i), lookat:=xlWhole).Offset(i - 8, 0) Set rngEnd = Range("E8:AI8").Find(what:=Range("D" & i), lookat:=xlWhole).Offset(i - 8, 0)
の部分を
Set rngStart = Range("C" & i).Offset(, Format(Range("C" & i), "d") + 1) Set rngEnd = Range("D" & i).Offset(, Format(Range("D" & i), "d"))
に変えてみてください。ただし日付が必ずE8セルから始まっているという前提です。 (se_9) 2015/05/13(水) 16:29
日付に関してなんですが
C4セルにスピンボタンを設置して2000〜2020の間の値を設定し
G4セルに同じくボタン配置で1〜12を設定して
E8のセルには=DATE($C$4,$G$4,1)という形で入っておりF8以降には=E8+1の形になっています。
カレンダーのように祝日と土日を条件付き書式で変えて使用したいので
このようにしてます。
(!) 2015/05/14(木) 11:39
うーん、私の方ではエラーは出ないのですが・・・。 ???さんのコードを使ってみてください。 (se_9) 2015/05/14(木) 15:15
(!) 2015/05/19(火) 11:22
エラーメッセージが出る原因は空白セルでした。他の部分の修正も少し加えて
Sub Sample()
Dim rngStart As Range, rngEnd As Range Dim BX As Single, BY As Single, EX As Single, EY As Single Dim LastRow As Long, i As Long Dim shp As Shape
For Each shp In ActiveSheet.Shapes shp.Delete Next
LastRow = Cells(Rows.Count, 3).End(xlUp).Row
For i = 9 To LastRow If Range("C" & i).Value = "" Or Range("D" & i).Value = "" Then Else Set rngStart = Range("C" & i).Offset(, Format(Range("C" & i).Value, "d") + 1) Set rngEnd = Range("D" & i).Offset(, Format(Range("D" & i).Value, "d"))
BX = rngStart.Left BY = rngStart.Top EX = rngEnd.Left + rngEnd.Width EY = rngEnd.Top
With ActiveSheet.Shapes.AddLine(BX, BY + 8, EX, EY + 8).Line .ForeColor.RGB = vbRed .Weight = 1.5 .EndArrowheadStyle = msoArrowheadTriangle End With End If Next
End Sub (se_9) 2015/05/19(火) 11:54
そういえばスピンボタンを配置していたんですよね。すいません。 同シート内の日付部分以外にオートシェイプの直線などがなければ
Sub Sample()
Dim rngStart As Range, rngEnd As Range Dim BX As Single, BY As Single, EX As Single, EY As Single Dim LastRow As Long, i As Long
ActiveSheet.Lines.Delete LastRow = Cells(Rows.Count, 3).End(xlUp).Row
For i = 9 To LastRow If Range("C" & i).Value = "" Or Range("D" & i).Value = "" Then Else Set rngStart = Range("C" & i).Offset(, Format(Range("C" & i).Value, "d") + 1) Set rngEnd = Range("D" & i).Offset(, Format(Range("D" & i).Value, "d"))
BX = rngStart.Left BY = rngStart.Top EX = rngEnd.Left + rngEnd.Width EY = rngEnd.Top
With ActiveSheet.Shapes.AddLine(BX, BY + 8, EX, EY + 8).Line .ForeColor.RGB = vbRed .Weight = 1.5 .EndArrowheadStyle = msoArrowheadTriangle End With End If Next
End Sub (se_9) 2015/05/19(火) 13:12
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.