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

zhlinger2030

附件： 新建 XLS 工作表 (3).rar (24.26 KB, 下载次数: 13)

2023-2-17 18:09 上传

点击文件名下载附件

lcluck2002

根据什么规则连线呢？
是否是这样：范围在14-17列，这四列中均只有一个有数据，按行次的递增连接有数据的单元格？

493861364

lcluck2002 发表于 2023-2-17 18:38
根据什么规则连线呢？
是否是这样：范围在14-17列，这四列中均只有一个有数据，按行次的递增连接有数据的 ...

我理解，楼主的意思就是从上至下，从左至右，有数据的单元格连线
限制在14-17列

准提部林

For k = 0 To 1
    c% = 14 ^ k  '14=N列
    With Cells(1, c).CurrentRegion
        .Rows.Hidden = False
        .Columns.Hidden = False
        rCount = .Rows.Count
        cCount = .Columns.Count
    End With
    For i = 2 To rCount - 1
        With Cells(i, c).Resize(, cCount).SpecialCells(xlCellTypeConstants)(1)
            x1 = .Left + .Width / 2
            y1 = .Top + .Height / 2
        End With
        With Cells(i + 1, c).Resize(, cCount).SpecialCells(xlCellTypeConstants)(1)
            x2 = .Left + .Width / 2
            y2 = .Top + .Height / 2
        End With
        With ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Line
            .DashStyle = msoLineSolid
            .Weight = 1.25
            .ForeColor.RGB = lineColor
        End With
    Next i
Next k

兩區同時處理~~

dsmch

1. Sub 宏2()
   
2. Dim rng As Range, c As Range, arr
   
3. ReDim arr(1 To 2000)
   
4. Set rng = [d2:q49] '区域范围
   
5. For Each sh In ActiveSheet.DrawingObjects
   
6.     sh.Delete
   
7. Next
   
8. w = [a2].Width
   
9. h = [a2].Height
   
10. For i = 2 To rng.EntireRow.Count + 1
    
11.     Set c = Application.Intersect(Rows(i), rng).Find("*")
    
12.     If Not c Is Nothing Then
    
13.         s = s + 1
    
14.         arr(s) = c.Address
    
15.     End If
    
16. Next
    
17. For i = 2 To s
    
18.     Set c1 = Range(arr(i - 1))
    
19.     Set c2 = Range(arr(i))
    
20.     x1 = c1.Left + w / 2: y1 = c1.Top + h / 2
    
21.     x2 = c2.Left + w / 2: y2 = c2.Top + h / 2
    
22.     With ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Line
    
23.         .DashStyle = msoLineSolid
    
24.         .Weight = 1.25
    
25.         .ForeColor.RGB = RGB(255, 0, 0)
    
26.     End With
    
27. Next
    
28. End Sub
    

复制代码

dsmch

……………………

micch

和前面的同一个思路不就行了，反正是连线，右边和左边有啥区别

perfect131

可以搞
https://club.excelhome.net/forum ... 46&pid=10720567

dsmch

1. Sub 宏2()
   
2. Dim rng As Range, c As Range, arr
   
3. For Each sh In ActiveSheet.DrawingObjects
   
4.     sh.Delete
   
5. Next
   
6. w = [a2].Width
   
7. h = [a2].Height
   
8. For Each rng In Union([a2:l49], [n2:u49]).Areas '两块区域范围
   
9.     ReDim arr(1 To 2000)
   
10.     s = 0
    
11.     For i = 2 To rng.EntireRow.Count + 1
    
12.         Set c = Application.Intersect(Rows(i), rng).Find("*")
    
13.         If Not c Is Nothing Then
    
14.             s = s + 1
    
15.             arr(s) = c.Address
    
16.         End If
    
17.     Next
    
18.     For i = 2 To s
    
19.         Set c1 = Range(arr(i - 1))
    
20.         Set c2 = Range(arr(i))
    
21.         x1 = c1.Left + w / 2: y1 = c1.Top + h / 2
    
22.         x2 = c2.Left + w / 2: y2 = c2.Top + h / 2
    
23.         With ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).Line
    
24.             .DashStyle = msoLineSolid
    
25.             .Weight = 1.25
    
26.             .ForeColor.RGB = RGB(255, 0, 0)
    
27.         End With
    
28.     Next
    
29.     Erase arr
    
30. Next
    
31. End Sub

复制代码

zhlinger2030

lcluck2002 发表于 2023-2-17 18:38
根据什么规则连线呢？
是否是这样：范围在14-17列，这四列中均只有一个有数据，按行次的递增连接有数据的 ...

连成后是这样子