[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『工程表の自動オートシェイプ』（！）
工程表を作成しています。
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.