[求助]如何在输入数字后l两条曲线自动发生对应的不同变化?

airsega

27uEOrVD.zip (51.39 KB, 下载次数: 19)

2007-2-19 13:16 上传

点击文件名下载附件
[求助]如何在输入数字后l两条曲线自动发生对应的不同变化?

[此贴子已经被作者于2007-2-19 13:18:05编辑过]

EdgeOfCity

把代码放在Sheet1的Worksheet_Change事件里面

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Err_Handler
If Target.Count = 1 And Target.Column = 2 And Target.Offset(-1, 0) <> "" Then
Dim rng As Range

Set rng = Shapes(Shapes.Count).TopLeftCell
    If Target.Address = Cells(rng.Row + 1, 2).Address Then
        Dim BeginX, Beginy, EndX, EndY
        Select Case Target.Offset(-1, 0)
            Case 7, 8, 9 '曲线往左下走一格
                BeginX = Shapes(Shapes.Count).Left
            Case 3, 4, 5, 6 '曲线往垂直下方走一格
                BeginX = Shapes(Shapes.Count).Left
            Case 0, 1, 2 '曲线往右下走一格
                BeginX = Shapes(Shapes.Count).Left + rng.Width
        End Select
        Select Case Target
            Case 7, 8, 9 '曲线往左下走一
                EndX = rng.Offset(0, -1).Left
            Case 3, 4, 5, 6 '曲线往垂直下方走一格
                EndX = rng.Left
            Case 0, 1, 2 '曲线往右下走一格
                EndX = rng.Offset(0, 1).Left
        End Select
                Beginy = Shapes(Shapes.Count).Top + rng.Height
                EndY = rng.Offset(2, 0).Top
                With Me.Shapes.AddLine(BeginX, Beginy, EndX, EndY).Line
                    .Weight = 1.5
                    .ForeColor.SchemeColor = 39
                End With
        End If
End If
Err_Handler:
    Exit Sub
End Sub

airsega

多谢楼上回答,可是我运行了一下,发现生成的曲线仍有错误,方向不对.

EdgeOfCity

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Err_Handler
If Target.Count = 1 And Target.Column = 2 And Target.Offset(-1, 0) <> "" Then
Dim rng As Range

Set rng = Shapes(Shapes.Count).TopLeftCell

    If Target.Address = Cells(rng.Row + 1, 2).Address Then

        Dim BeginX, Beginy, EndX, EndY
        Select Case Target.Offset(-1, 0)
            Case 7, 8, 9 '曲线往左下走一格
                BeginX = Shapes(Shapes.Count).Left
            Case 3, 4, 5, 6 '曲线往垂直下方走一格
                BeginX = Shapes(Shapes.Count).Left
            Case 0, 1, 2 '曲线往右下走一格
                BeginX = Shapes(Shapes.Count).Left + rng.Width
        End Select
        Select Case Target
            Case 7, 8, 9 '曲线往左下走一
                EndX = BeginX - rng.Width
            Case 3, 4, 5, 6 '曲线往垂直下方走一格
                EndX = BeginX
            Case 0, 1, 2 '曲线往右下走一格
                EndX = BeginX + rng.Width
            Case Else
                Exit Sub
        End Select
                Beginy = Shapes(Shapes.Count).Top + rng.Height
                EndY = Beginy + rng.Height
                With Me.Shapes.AddLine(BeginX, Beginy, EndX, EndY).Line
                    .Weight = 1.5
                    .ForeColor.SchemeColor = 39
                End With
        End If
End If
Err_Handler:
    Exit Sub
End Sub

airsega

还是很感谢ＥＤＧＥ的热情帮助，现在还想再做一条曲线，设定１，5，７向右走，０，３，６，９向垂直下走，２，4，８向左走，这条曲线和原来的曲线并列在一张工作表内，方向完全不同．该如何设定ＣＨＡＧＥ事件，使得两条曲线各自往自己的方向走？

问题多了点，大过年的能得到ＥＤＧＥ的帮助，还是很感激的！

[此贴子已经被作者于2007-2-19 13:19:21编辑过]

三十而立

对我来说难了点儿

airsega

原来的问题已经解决，但现在我又新画了一条曲线，还是根据相同的数据，设定:当数字为1，5，7时,曲线往左下走一网格,当数字为0，3，6，9时,曲线往垂直下方走一格,当数字为2，4，8时,曲线往右下走一格.    颜色为：Selection.ShapeRange.Line.ForeColor.SchemeColor = 25。这条曲线和原来的颜色为39的曲线并列在一张表上。该如何重新设定CHANGE事件，使两条曲线沿着它们各自的轨迹进行运动而不产生冲突？多谢了！

airsega

没人回答吗?真希望有人能帮忙

EdgeOfCity

建议你每条直线的名称改成与期数相关的.这样利于以后的定位.

如:

A直线:2006001A1,2006001A2...

B直线:2006001B1,2006001B2...

你现在只有第一条线,用个循环的方法把原来已加的线段改名

以后再增加的线段就按命名规则递增.

airsega

果真是好方法,多谢EDGE,我也摸索出了一段代码,就在你写的代码的基础上,很笨很耗时间的一个做法,但是可以完成两条曲线一起变化,先将就着用用啦!