Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

数据透视表40+个常用小技巧,让你一次学会!
查看: 238|回复: 3

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

[复制链接]
发表于 2022-5-13 15:58 | 显示全部楼层 |阅读模式
目前这个代码只能实现第一组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

最佳答案
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. If Not fore Is Nothing And Len(r.Text) > 0 Then
  6. Set back = r
  7.     x1 = fore.Left + fore.Width / 2
  8.     y1 = fore.Top + fore.Height / 2
  9.     x2 = back.Left + back.Width / 2
  10.     y2 = back.Top + back.Height / 2
  11.      Sheet3.Shapes.AddLine x1, y1, x2, y2
  12. End If

  13. If Len(r.Text) > 0 Then
  14.     Set fore = r
  15. End If

  16. Next
  17. End Sub

  18. Sub main()
  19. Dim shp As Shape   ''排除图标按钮
  20.     For Each shp In Sheet3.Shapes
  21.         If shp.Type <> 8 And shp.Type <> 12 Then shp.Delete
  22.     Next

  23. Dim rng As Range
  24.     For i = 1 To Range("AW5:DH5").Columns.Count Step 8
  25.     Set rng = Range("AW5:DH5")(i)
  26.     addLineTo rng.Offset(1, 0).Resize(rng.End(xlDown).Row - rng.Row, 8)
  27.     Next
  28. End Sub
复制代码

折线问题.zip

383.32 KB, 下载次数: 17

excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
 楼主| 发表于 2022-5-16 13:46 | 显示全部楼层
顶起来!希望大神帮忙看看,谢谢。
回复

使用道具 举报

发表于 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. If Not fore Is Nothing And Len(r.Text) > 0 Then
  6. Set back = r
  7.     x1 = fore.Left + fore.Width / 2
  8.     y1 = fore.Top + fore.Height / 2
  9.     x2 = back.Left + back.Width / 2
  10.     y2 = back.Top + back.Height / 2
  11.      Sheet3.Shapes.AddLine x1, y1, x2, y2
  12. End If

  13. If Len(r.Text) > 0 Then
  14.     Set fore = r
  15. End If

  16. Next
  17. End Sub

  18. Sub main()
  19. Dim shp As Shape   ''排除图标按钮
  20.     For Each shp In Sheet3.Shapes
  21.         If shp.Type <> 8 And shp.Type <> 12 Then shp.Delete
  22.     Next

  23. Dim rng As Range
  24.     For i = 1 To Range("AW5:DH5").Columns.Count Step 8
  25.     Set rng = Range("AW5:DH5")(i)
  26.     addLineTo rng.Offset(1, 0).Resize(rng.End(xlDown).Row - rng.Row, 8)
  27.     Next
  28. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2022-5-17 17:36 | 显示全部楼层
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2022-8-15 12:00 , Processed in 0.183034 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表