[已解决]自动划线命令，多组同时进行

kkll0914

目前这个代码只能实现第一组aw:bd列数据的自动划线命令，
有没有大神帮忙把这个代码调整下，我想一次性把剩下的
be:bl列,bm:bt列,bu:cb列,cc:cj列,ck:crv列,cs:cz列,da:dh列,
这七组数据同时进行自动划线。谢谢

Sub Alianxian1() '折线
Dim shp As Shape   ''排除图标按钮
    For Each shp In Sheet3.Shapes
        If shp.Type <> 8 And shp.Type <> 12 Then shp.Delete
    Next
Dim x1, y1, x2, y2
Dim i As Integer
Dim rng1 As Range, rng2 As Range
For i = 7 To Sheet3.Range("aw5").End(xlDown).Row '表头行+2和表头行位置
    For Each rng1 In Sheet3.Range("aw" & i - 1 & ":bd" & i - 1) '表头行开始和结束位置
       If rng1 <> "" Then Exit For
    Next rng1
    For Each rng2 In Sheet3.Range("aw" & i & ":bd" & i) '表头行开始和结束位置
       If rng2 <> "" Then Exit For
    Next rng2
    x1 = rng1.Left + rng1.Width / 2
    y1 = rng1.Top + rng1.Height / 2
    x2 = rng2.Left + rng2.Width / 2
    y2 = rng2.Top + rng2.Height / 2
    Sheet3.Shapes.AddLine x1, y1, x2, y2
Next i
End Sub

最佳答案

月排行榜 / 总排行榜

eennoo

2022-5-16 23:20

1. Sub addLineTo(arrRange As Range)
   
2. Dim r As Range, fore As Range, back As Range
   
3. Set fore = Nothing
   
4. For Each r In arrRange
   
5. 
   
6. If Not fore Is Nothing And Len(r.Text) > 0 Then
   
7. Set back = r
   
8.     x1 = fore.Left + fore.Width / 2
   
9.     y1 = fore.Top + fore.Height / 2
   
10.     x2 = back.Left + back.Width / 2
    
11.     y2 = back.Top + back.Height / 2
    
12.      Sheet3.Shapes.AddLine x1, y1, x2, y2
    
13. End If
    
14. 
    
15. If Len(r.Text) > 0 Then
    
16.     Set fore = r
    
17. End If
    
18. 
    
19. Next
    
20. End Sub
    
21. 
    
22. Sub main()
    
23. Dim shp As Shape   ''排除图标按钮
    
24.     For Each shp In Sheet3.Shapes
    
25.         If shp.Type <> 8 And shp.Type <> 12 Then shp.Delete
    
26.     Next
    
27. 
    
28. Dim rng As Range
    
29.     For i = 1 To Range("AW5:DH5").Columns.Count Step 8
    
30.     Set rng = Range("AW5:DH5")(i)
    
31.     addLineTo rng.Offset(1, 0).Resize(rng.End(xlDown).Row - rng.Row, 8)
    
32.     Next
    
33. End Sub
    

复制代码

跳转到最佳答案楼层

kkll0914

顶起来！希望大神帮忙看看，谢谢。

eennoo

1. Sub addLineTo(arrRange As Range)
   
2. Dim r As Range, fore As Range, back As Range
   
3. Set fore = Nothing
   
4. For Each r In arrRange
   
5. 
   
6. If Not fore Is Nothing And Len(r.Text) > 0 Then
   
7. Set back = r
   
8.     x1 = fore.Left + fore.Width / 2
   
9.     y1 = fore.Top + fore.Height / 2
   
10.     x2 = back.Left + back.Width / 2
    
11.     y2 = back.Top + back.Height / 2
    
12.      Sheet3.Shapes.AddLine x1, y1, x2, y2
    
13. End If
    
14. 
    
15. If Len(r.Text) > 0 Then
    
16.     Set fore = r
    
17. End If
    
18. 
    
19. Next
    
20. End Sub
    
21. 
    
22. Sub main()
    
23. Dim shp As Shape   ''排除图标按钮
    
24.     For Each shp In Sheet3.Shapes
    
25.         If shp.Type <> 8 And shp.Type <> 12 Then shp.Delete
    
26.     Next
    
27. 
    
28. Dim rng As Range
    
29.     For i = 1 To Range("AW5:DH5").Columns.Count Step 8
    
30.     Set rng = Range("AW5:DH5")(i)
    
31.     addLineTo rng.Offset(1, 0).Resize(rng.End(xlDown).Row - rng.Row, 8)
    
32.     Next
    
33. End Sub
    

复制代码

kkll0914

eennoo 发表于 2022-5-16 23:20

多谢大神！