如图，14-17列怎么也能自动连线，有思路就送花

zhlinger2030 · 发表于 2023-2-17 21:25

准提部林发表于 2023-2-17 19:43
For k = 0 To 1
c% = 14 ^ k '14=N列
With Cells(1, c).CurrentRegion

对的，大佬太牛了

zhlinger2030 · 发表于 2023-2-17 21:27

连成后是这样子

准提部林 · 发表于 2023-2-17 21:43

重寫一個//每行只跑一次
Sub myLine1()
Dim xR As Range, A As Range, B As Range, N&, x1, x2, y1, y2
ActiveSheet.Lines.Delete
For k = 0 To 1
c% = 14 ^ k: N = 0
For Each xR In Cells(1, c).CurrentRegion.Rows
      If xR.Row < 2 Then GoTo x01
      Set A = xR.Find("*")
      x1 = A.Left + A.Width / 2
      y1 = A.Top + A.Height / 2
      If N > 0 Then
         With ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Line
            .DashStyle = msoLineSolid
            .Weight = 1.25
            .ForeColor.RGB = Range("M1").Interior.Color
         End With
      End If
      N = 1: Set B = A: x2 = x1: y2 = y1
x01: Next
Next k
End Sub

准提部林 · 发表于 2023-2-17 21:48

zhlinger2030 发表于 2023-2-17 21:25
对的，大佬太牛了

這是//接棒式的寫法
代碼審核中...先看圖

zhlinger2030 · 发表于 2023-2-17 21:52

dsmch 发表于 2023-2-17 19:55
……………………

大佬，好像还有点小问题，不知道怎么解决，完成后应该是这样无标题1.png

dsmch · 发表于 2023-2-17 21:59

zhlinger2030 发表于 2023-2-17 21:52
大佬，好像还有点小问题，不知道怎么解决，完成后应该是这样

已修改，代码审核中

zhlinger2030 · 发表于 2023-2-17 22:02

dsmch 发表于 2023-2-17 21:59
已修改，代码审核中

好的，谢大佬

zhlinger2030 · 发表于 2023-2-18 09:19

准提部林发表于 2023-2-17 21:43
重寫一個//每行只跑一次
Sub myLine1()
Dim xR As Range, A As Range, B As Range, N&, x1, x2, y1, y2

大佬，我又加了一组数据，出现这种情况，怎么弄
无标题2.png

准提部林 · 发表于 2023-2-18 10:33

zhlinger2030 发表于 2023-2-18 09:19
大佬，我又加了一组数据，出现这种情况，怎么弄

如圖//修改紅色字部份

zhlinger2030 · 发表于 2023-2-18 12:44

准提部林发表于 2023-2-18 10:33
如圖//修改紅色字部份

大神，麻烦看看，为啥放到原表格中就不行了，是那出问题了

测试.rar (38.35 KB, 下载次数: 1)

		自动登录	找回密码
密码			免费注册

[求助] 如图，14-17列怎么也能自动连线，有思路就送花

评分