Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 4511|回复: 11

[已解决]优化VBA代码!

[复制链接]
发表于 2015-3-25 20:55 | 显示全部楼层 |阅读模式
求助,论坛中的各位前辈,希望帮助我优化一段段VBA代码,具体内容详见附件!本人感激之至!谢谢!谢谢! 求助VBA代码优化.rar (25 KB, 下载次数: 21)
发表于 2015-3-27 10:04 | 显示全部楼层
  1. Sub Macro1()
  2. Dim rng As Range, i&
  3. For Each m In ActiveSheet.Shapes
  4.     If m.Type <> 8 Then m.Delete
  5. Next
  6. For i = 20 To 31
  7.     tj = Cells(i, 6)
  8.     If InStr(tj, "±") Then
  9.         x = Val(Mid(tj, 2))
  10.         For j = 8 To 17
  11.             s = Cells(i, j)
  12.             If Not (s <= x And s >= 0 - x) Then GoSub 100
  13.         Next
  14.     ElseIf InStr(tj, "<") Then
  15.         x = Val(Mid(tj, 2))
  16.         For j = 8 To 17
  17.             s = Cells(i, j)
  18.             If Not s < x Then GoSub 100
  19.         Next
  20.     ElseIf InStr(tj, ">") Then
  21.         x = Val(Mid(tj, 2))
  22.         For j = 8 To 17
  23.             s = Cells(i, j)
  24.             If Not s > x Then GoSub 100
  25.         Next
  26.     ElseIf InStr(tj, "~") Then
  27.         x = Split(tj, "~")
  28.         For j = 8 To 17
  29.             s = Cells(i, j)
  30.             If Not (s >= Val(x(0)) And s <= Val(x(1))) Then GoSub 100
  31.         Next
  32.     ElseIf InStr(tj, ";") Then
  33.         x = Split(tj, ";")
  34.         For j = 8 To 17
  35.             s = Cells(i, j)
  36.             If Not (s <= Val(x(0)) And s >= Val(x(1))) Then GoSub 100
  37.         Next
  38.     Else
  39.         x = Val(tj)
  40.         For j = 8 To 17
  41.             s = Cells(i, j)
  42.             If Not s <= x Then GoSub 100
  43.         Next
  44.     End If
  45. Next
  46. If Not rng Is Nothing Then
  47.     For Each m In rng
  48.         X1 = m.Left + m.Width * 0.25
  49.         Y1 = m.Top + m.Height * 0.25
  50.         X2 = m.Width * 0.5
  51.         Y2 = m.Height * 0.5
  52.         With ActiveSheet.Shapes.AddShape(msoShapeOval, X1, Y1, X2, Y2)
  53.             .Fill.Transparency = 1
  54.             .Line.ForeColor.SchemeColor = 10
  55.             .Line.Weight = 1
  56.         End With
  57.     Next
  58. End If
  59. Exit Sub
  60. 100:
  61. If rng Is Nothing Then Set rng = Cells(i, j) Else Set rng = Union(rng, Cells(i, j))
  62. Return
  63. End Sub
复制代码
回复

使用道具 举报

发表于 2015-3-27 10:24 | 显示全部楼层
………………

求助VBA代码优化.zip

17.18 KB, 下载次数: 9

回复

使用道具 举报

 楼主| 发表于 2015-3-28 11:12 | 显示全部楼层
dsmch 发表于 2015-3-27 10:24
………………

非常 感谢老师的优化,使用效果很好,不过存在一点疑问,例:如果数据区域1、2以外均存在图形或图片均会被删除或统计,如何才能实现只删除或统计数据区域1、2内的标记呢?
回复

使用道具 举报

发表于 2015-3-28 11:23 | 显示全部楼层    本楼为最佳答案   
Sub Macro1()
Dim rng As Range, i&
For Each m In ActiveSheet.Shapes
    If Not Application.Intersect([h20:q31], m.TopLeftCell) Is Nothing Then
       If m.Type <> 8 Then m.Delete
    End If
Next
For i = 20 To 31
    tj = Cells(i, 6)
    If InStr(tj, "±") Then
        x = Val(Mid(tj, 2))
        For j = 8 To 17
            s = Cells(i, j)
            If Not (s <= x And s >= 0 - x) Then GoSub 100
        Next
    ElseIf InStr(tj, "<") Then
        x = Val(Mid(tj, 2))
        For j = 8 To 17
            s = Cells(i, j)
            If Not s < x Then GoSub 100
        Next
    ElseIf InStr(tj, ">") Then
        x = Val(Mid(tj, 2))
        For j = 8 To 17
            s = Cells(i, j)
            If Not s > x Then GoSub 100
        Next
    ElseIf InStr(tj, "~") Then
        x = Split(tj, "~")
        For j = 8 To 17
            s = Cells(i, j)
            If Not (s >= Val(x(0)) And s <= Val(x(1))) Then GoSub 100
        Next
    ElseIf InStr(tj, ";") Then
        x = Split(tj, ";")
        For j = 8 To 17
            s = Cells(i, j)
            If Not (s <= Val(x(0)) And s >= Val(x(1))) Then GoSub 100
        Next
    Else
        x = Val(tj)
        For j = 8 To 17
            s = Cells(i, j)
            If Not s <= x Then GoSub 100
        Next
    End If
Next
If Not rng Is Nothing Then
    For Each m In rng
        X1 = m.Left + m.Width * 0.25
        Y1 = m.Top + m.Height * 0.25
        X2 = m.Width * 0.5
        Y2 = m.Height * 0.5
        With ActiveSheet.Shapes.AddShape(msoShapeOval, X1, Y1, X2, Y2)
            .Fill.Transparency = 1
            .Line.ForeColor.SchemeColor = 10
            .Line.Weight = 1
        End With
    Next
End If
[a33] = "共实测  110  点,其中合格 " & 110 - rng.Count & " 点,不合格 " & rng.Count & " 点,合格率 " & Round((110 - rng.Count) * 100 / 110, 2) & "%"
Exit Sub
100:
If rng Is Nothing Then Set rng = Cells(i, j) Else Set rng = Union(rng, Cells(i, j))
Return
End Sub
回复

使用道具 举报

 楼主| 发表于 2015-3-28 12:57 | 显示全部楼层
dsmch 发表于 2015-3-28 11:23
Sub Macro1()
Dim rng As Range, i&
For Each m In ActiveSheet.Shapes

谢谢老师的指导,现在有个新问题,如果数据区域单元格为空时,包含“~”,“>”符号所在行也会被选中?另For i = 20 To 31在运行时能否跳过28呢?

点评

增加一个判断,如为空,则循环下一步  发表于 2015-3-28 13:26
回复

使用道具 举报

 楼主| 发表于 2015-3-28 13:36 | 显示全部楼层
279590778 发表于 2015-3-28 12:57
谢谢老师的指导,现在有个新问题,如果数据区域单元格为空时,包含“~”,“>”符号所在行也会被选中?另 ...

谢谢你的指导!感激不尽。
回复

使用道具 举报

 楼主| 发表于 2015-3-31 10:32 | 显示全部楼层
dsmch 发表于 2015-3-28 11:23
Sub Macro1()
Dim rng As Range, i&
For Each m In ActiveSheet.Shapes

dsmch大师,你好!
在以下代码中,应如何指定只删除 [H20:Q27] 和 [H29:Q31] 区域的图形呢?谢谢?
If Not Application.Intersect([H20:Q31], m.TopLeftCell) Is Nothing Then
    If m.Type <> 8 Then m.Delete
End If

点评

Set rng = Union([H20:Q27], [H29:Q31]) If Not Application.Intersect(rng, m.TopLeftCell) Is Nothing Then  发表于 2015-3-31 10:36
回复

使用道具 举报

 楼主| 发表于 2015-3-31 14:02 | 显示全部楼层
本帖最后由 279590778 于 2015-3-31 14:07 编辑
dsmch 发表于 2015-3-28 11:23
Sub Macro1()
Dim rng As Range, i&
For Each m In ActiveSheet.Shapes


dsmch老师你好,感谢你的耐心指导。
如下图所示:
“图片在11楼”
单在表格中增加表单控件,如何根据选择判断当列数据呢?谢谢!
回复

使用道具 举报

 楼主| 发表于 2015-3-31 14:06 | 显示全部楼层
dsmch老师你好,感谢你的耐心指导。
如下图所示:
当在表格中增加表单控件,如何根据选择判断当列数据呢?谢谢!
捕获.JPG

点评

通常不用控件,让其他人帮你  发表于 2015-3-31 14:23
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 02:42 , Processed in 0.741660 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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