Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


8039 / 13644 ツリー ←次へ | 前へ→

【35423】どこにでも線を引きたい Ju- 06/3/3(金) 23:26 質問[未読]
【35426】Re:どこにでも線を引きたい やっちん 06/3/4(土) 0:14 発言[未読]

【35423】どこにでも線を引きたい
質問  Ju-  - 06/3/3(金) 23:26 -

引用なし
パスワード
   下記プログラムで、1列目に行を挿入した場合に問題なく線を引くためには、どこを変更したらいいでしょうか?
------------------------------------------------------------------
------------------------------------------------------------------

このようなシートで、B列に入れた数だけ、C列以降に線を引きます。
    A    B   C     D     E     F    G    H     I
1  開始日 日数 5月1日 5月2日 5月3日 5月4日 5月5日 5月6日 5月7日
2  5月1日  2  -------------
3  5月3日  4             ----------------------------
4  5月7日  1                                   ------
5  5月2日  5        ------------------------------------  
6  5月4日  3                   ---------------------
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim i As Integer, j As Long, futosa As Variant, LastCol As Integer, k As Integer
 Dim s As Shape, wLeft, wTop, wRight, wBottom
 Dim shapeLeft, shapeTop, shapeRight, shapeBottom
 Dim iroNO As String, iro As Variant
 On Error GoTo trap
 i = Target.Value
 j = Target.Row
 If Target.Column <> 2 Or j = 1 Or i <= 0 Or i > 31 Then
  Exit Sub
 End If
 With Application
  Do
   futosa = .InputBox("太さを指定してください?", "整数入力", 5, Type:=1)
   If VarType(futosa) = vbBoolean Then
    .EnableEvents = False
    .Undo
    .EnableEvents = True
    Exit Sub
   End If
   If futosa > 0 Then
    If futosa <= Target.Height Then
     Exit Do
     Else
     MsgBox "セルの縦幅よりも太いです。もう少し細い線を指定してください"
    End If
   End If
  Loop
   iroNO = " 8)黒 9)白 10)赤 11)黄緑" & vbCrLf & "12)青 13)黄 14)ピンク 15)水色"
  Do
   iro = .InputBox("線の色は、何番にしますか?" & vbCrLf & iroNO, "線の色指定", 8, Type:=1)
   If VarType(iro) = vbBoolean Then
    .EnableEvents = False
    .Undo
    .EnableEvents = True
    Exit Sub
   End If
   Select Case iro
    Case 8 To 15
     Exit Do
   End Select
   Loop
 End With
  With Rows(j)
  wTop = .Top
  wLeft = .Left
  wBottom = .Top + .Height
  wRight = .Left + .Width
 End With
   For Each s In ActiveSheet.Shapes
   shapeTop = s.Top
   shapeLeft = s.Left
   shapeBottom = s.Top + s.Height
   shapeRight = s.Left + s.Width
   If wTop <= shapeTop And wLeft <= shapeLeft And _
   wBottom >= shapeBottom And wRight >= shapeRight Then
   s.Delete
   End If
  Next
 LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
 For k = 3 To LastCol
  If Target.Offset(0, -1).Value = Cells(1, k) Then
   With ActiveSheet.Shapes.AddLine(Cells(j, k).Left, Target.Top + Target.Height / 2, _
       Cells(j, k + i).Left, Target.Top + Target.Height / 2).Line
       .Weight = futosa
    .ForeColor.SchemeColor = iro
   End With
   Exit For
  End If
 Next
 Target.Select
 trap:
End Sub

【35426】Re:どこにでも線を引きたい
発言  やっちん  - 06/3/4(土) 0:14 -

引用なし
パスワード
   ▼Ju- さん:
こんばんは。
>1列目に行を挿入した場合
この意味がわかりません。
例えばどういう操作ですか?

8039 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free