Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
楼主: 兰色幻想

VBA80集第24集答疑专贴

  [复制链接]
发表于 2014-10-7 21:46 | 显示全部楼层
josonxu 发表于 2014-3-31 13:22
For x = 1 To UBound(arr)
   If x = UBound(arr) And sr  "" Then Range(Left(sr, Len(sr) - 1)).Interio ...

For x = 1 To UBound(arr)
   If arr(x, 1) > 500 Then
      sr1 = sr
      sr = sr & "A" & x + 1 & ":D" & x + 1 & ","
      If Len(sr) > 255 Then
        sr = sr1
        Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
        'Range("A" & x + 1 & ":D" & x + 1).Interior.ColorIndex = 3
        sr = ""
        x = x - 1
      End If
   End If
   If x = UBound(arr) And sr <> "" Then Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
Next x

增加一句蓝色的,再将红色的那一句由开头移到后面就可以了。
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

发表于 2015-5-13 19:41 | 显示全部楼层
leessn 发表于 2013-3-10 21:22
我觉得可以去掉最后的”x=x-1"。
当len(sr)>255的时候,执行下面的代码:
If Len(sr) > 255 Then
  1. Sub 数组方法2()
  2. Dim arr, t
  3. Dim x As Integer, x1 As Integer
  4. Dim sr As String, sr1 As String
  5. 清除颜色
  6. t = Timer
  7. arr = Range("d2:d" & Range("a65536").End(xlUp).Row)
  8. For x = 1 To UBound(arr)
  9.    If x = UBound(arr) Then Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
  10.    If arr(x, 1) > 500 Then
  11.       sr1 = sr
  12.       x1 = x + 1
  13.       Do
  14.         x = x + 1
  15.       Loop Until arr(x, 1) <= 500
  16.       
  17.       sr = sr & "A" & x1 & ":D" & x & ","
  18.       If Len(sr) > 255 Then               
  19.         sr = sr1
  20. <font color="#ff0000">        x = x1 - 1                                  ‘ 当大于sr长度 大于255时, 这里 x 已经还原到预期位置</font>
  21.         Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
  22.         sr = ""
  23.       End If
  24. <font color="#ff0000">      x = x - 1                                    '当sr长度 大于255时,前面已经将x还原到预期位置,为何这里还要再次减1</font>
  25.    End If                                         ‘虽结果不会有问题,是否有其它方面的考虑, 请解释一下?
  26. Next x
  27. MsgBox Timer - t


  28. End Sub
复制代码
回复

使用道具 举报

发表于 2015-10-12 16:29 | 显示全部楼层
本帖最后由 jbljypx 于 2015-10-12 21:36 编辑

确实有些小的漏洞。如原题数组方法1中:
D80>500,没有着色;
最后一行D10000>500时,不会着色。
另外,数组方法2中,有“下标溢出”的报错。

下面是本人斗胆修改的程序(测试效果令人满意):
  1. Sub 数组方法1()
  2. Dim arr, t, i
  3. Dim x As Integer
  4. Dim sr As String, sr1 As String
  5. 清除颜色
  6. t = Timer
  7. arr = Range("d2:d" & Range("a65536").End(xlUp).Row)
  8. For x = 1 To UBound(arr)
  9. If x = UBound(arr) And sr <> "" Then Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
  10. If x = UBound(arr) And arr(x, 1) > 500 Then 'jbl新增语句
  11. Range("A" & x + 1 & ":D" & x + 1).Interior.ColorIndex = 3: MsgBox Timer - t: Exit Sub 'jbl新增语句
  12. End If
  13. If x = UBound(arr) And arr(x, 1) <= 500 Then 'jbl新增语句
  14. MsgBox Timer - t: Exit Sub 'jbl新增语句
  15. End If
  16. If arr(x, 1) > 500 Then
  17. sr1 = sr
  18. sr = sr & "A" & x + 1 & ":D" & x + 1 & ","
  19. i = Len(sr) 'jbl增加的观察语句
  20. If Len(sr) > 255 Then
  21. sr = sr1
  22. x = x - 1
  23. Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
  24. sr = ""
  25. i = "" 'jbl增加的观察语句
  26. End If
  27. End If
  28. 'If x = 9998 Then Stop 'jbl增加的终止语句,以观察程序的结尾运行情况
  29. Next x
  30. MsgBox Timer - t
  31. End Sub


  32. Sub 数组方法2()
  33. Dim arr, t, i, x1
  34. Dim x As Integer
  35. Dim sr As String, sr1 As String
  36. 清除颜色
  37. t = Timer
  38. arr = Range("d2:d" & Range("a65536").End(xlUp).Row + 1) '+1是避免当x=10000时,出现“下标越界”
  39. For x = 1 To UBound(arr)
  40. If x = UBound(arr) And sr <> "" Then
  41. Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
  42. MsgBox Timer - t
  43. Exit Sub
  44. End If
  45. If arr(x, 1) > 500 Then
  46. sr1 = sr
  47. x1 = x + 1
  48. Do
  49. x = x + 1
  50. Loop Until arr(x, 1) <= 500
  51. sr = sr & "A" & x1 & ":D" & x & ","
  52. i = Len(sr) 'jbl增加的观察语句
  53. If Len(sr) > 255 Then
  54. sr = sr1
  55. x = x1 - 1
  56. Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
  57. sr = ""
  58. i = "" 'jbl增加的观察语句
  59. End If
  60. x = x - 1
  61. End If
  62. 'If x = 9996 Then Stop 'jbl增加的终止语句,以观察程序的结尾运行情况
  63. Next x
  64. MsgBox Timer - t
  65. End Sub


  66. Sub 数组方法3() '本方法速度最快。
  67. Dim arr, t, i, x1
  68. Dim x As Integer
  69. Dim sr As String, sr1 As String
  70. 清除颜色
  71. t = Timer
  72. arr = Range("d2:d" & Range("a65536").End(xlUp).Row + 1) '+1是避免当x=10000时,出现“下标越界”
  73. For x = 1 To UBound(arr)
  74. If x = UBound(arr) And sr <> "" Then
  75. Application.Intersect(Range("a:d"), Range(Left(sr, Len(sr) - 1))).Interior.ColorIndex = 3
  76. MsgBox Timer - t
  77. Exit Sub
  78. End If
  79. If arr(x, 1) > 500 Then
  80. sr1 = sr
  81. x1 = x + 1
  82. Do
  83. x = x + 1
  84. Loop Until arr(x, 1) <= 500
  85. sr = sr & x1 & ":" & x & ","
  86. i = Len(sr) 'jbl增加的观察语句
  87. If Len(sr) > 255 Then
  88. sr = sr1
  89. x = x1 - 1
  90. Application.Intersect(Range("a:d"), Range(Left(sr, Len(sr) - 1))).Interior.ColorIndex = 3
  91. sr = ""
  92. i = "" 'jbl增加的观察语句
  93. End If
  94. x = x - 1
  95. End If
  96. 'If x = 9996 Then Stop 'jbl增加的终止语句,以观察程序的结尾运行情况
  97. Next x
  98. MsgBox Timer - t
  99. End Sub


  100. Sub 数组方法4() '此例说明:虽然Union()可以突破Range()括号中256个上限字符数的限制,但运行时间太长(约64秒),没有实际使用的意义。
  101. Dim sr As Range
  102. Dim arr, t, x As Integer, k As Integer, aa As String
  103. 清除颜色
  104. t = Timer
  105. arr = Range("d2:d" & Range("a65536").End(xlUp).Row)
  106. For x = 1 To UBound(arr)
  107. If arr(x, 1) > 500 Then
  108. k = k + 1
  109. If k = 1 Then
  110. Set sr = Range("A" & x + 1 & ":D" & x + 1)
  111. Else
  112. Set sr = Union(sr, Range("A" & x + 1 & ":D" & x + 1))
  113. End If
  114. aa = sr.Address '观察用语句
  115. End If
  116. Next
  117. sr.Interior.ColorIndex = 3
  118. MsgBox Timer - t
  119. End Sub
  120. '上述"数组方法4",是由jbl增补的,以作对比学习用。
  121. 'jbl的一个结论:无论使用Union()方法或Range()对象,括号内字符数不要超过256.
复制代码
回复

使用道具 举报

发表于 2016-1-22 15:11 | 显示全部楼层
For x = 1 To UBound(arr)
   'If x = UBound(arr) And sr <> "" Then Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
   If arr(x, 1) > 500 Then
      sr1 = sr
      sr = sr & "A" & x + 1 & ":D" & x + 1 & ","
      If Len(sr) > 255 Then
        sr = sr1
        Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
        sr = ""
        x = x - 1
      End If
    'If x = UBound(arr) And sr <> "" Then Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
   End If
   If x = UBound(arr) And sr <> "" Then Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
Next x
请问程序中的红色字的语句为什么不能放在这个位置?
回复

使用道具 举报

发表于 2016-1-22 16:54 | 显示全部楼层
leessn 发表于 2013-3-10 21:22
我觉得可以去掉最后的”x=x-1"。
当len(sr)>255的时候,执行下面的代码:
If Len(sr) > 255 Then

这样理解不对,你可以去试着运行程序,结果是有问题的。
如果没有x=x-1那么就会漏掉了一部分>500的行,比如在x=200时arr(200,1)>500,但是len(sr)>255了,如果没有x=x-1这一句,那么将会向下进行循环,也就是循环到x=201,从而漏掉了x=200.
回复

使用道具 举报

发表于 2017-1-21 23:29 | 显示全部楼层
  1. Sub 数组方法()
  2. Dim arr, t
  3. Dim x As Integer
  4. Dim sr As String, sr1 As String
  5. 清除颜色
  6. t = Timer
  7. arr = Range("d2:d" & Range("a65536").End(xlUp).Row)
  8. For x = 1 To UBound(arr)
  9.    If x = UBound(arr) And sr <> "" Then Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
  10.    If arr(x, 1) > 500 Then
  11.       sr1 = sr
  12.       sr = sr & "A" & x + 1 & ":D" & x + 1 & ","
  13.       If Len(sr) > 255 Then
  14.         sr = sr1
  15.         Range("A" & x + 1 & ":D" & x + 1).Interior.ColorIndex = 3              '修正原来代码的错误之处
  16.         Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 3
  17.         sr = ""
  18.       End If
  19.    End If
  20. Next x
  21. MsgBox Timer - t
  22. End Sub
复制代码
回复

使用道具 举报

发表于 2017-7-8 11:35 | 显示全部楼层
chqyz 发表于 2011-8-10 17:24
请教老师,关于数组2中的疑问:
For x = 1 To UBound(arr)
   If x = UBound(arr) Then Range(Left(sr,  ...

开始也不明白,一步步调试一下后,才明白每次外循环后X会自动加1,所以此处要减1
回复

使用道具 举报

发表于 2017-11-10 23:21 | 显示全部楼层
本帖最后由 hert25 于 2017-11-10 23:29 编辑

本人学习到这一课以后,发现,里面讲解的数组方法是存在逻辑不严谨会导致出错之处,因我也是新手,这一课我消化了三天才改好代码,不知兰老师为什么不在这里更改一下代码,后学之人也就不用犯错了,发这个代码是为了让新手少走些跟我一样的弯路,省些时间学习,向兰老师致敬,您的付出是我等后学之人的明灯.三种数组方法时间差不多,可能是数据太少的原因吧,但三种思路却是学习的好材料.
代码如下
Sub 数组方法1()
Dim arr, t
Dim x As Integer
Dim sr As String, sr1 As String
t = Timer
Range("a:d").Interior.ColorIndex = xlNone
arr = Range("d2:d" & Range("d1").End(4).Row)
For x = 1 To UBound(arr)
  If arr(x, 1) > 500 Then
    sr1 = sr
    sr = sr & "A" & x + 1 & ":D" & x + 1 & ","
  If Len(sr) > 255 Then
    sr = sr1
    Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 4
    sr = "A" & x + 1 & ":D" & x + 1 & ","
  End If
  End If
Next x
Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 4
MsgBox Timer - t
End Sub

Sub 数组方法2()
t = Timer
Dim arr
Dim x%, x1%
Dim sr As String, sr1 As String
Range("a:d").Interior.ColorIndex = xlNone
arr = Range("d2:d" & Range("d1").End(4).Row)
For x = 1 To UBound(arr)
  If arr(x, 1) > 500 Then
     sr1 = sr
     x1 = x + 1
    Do
       x = x + 1
       If x = UBound(arr) + 1 Then
         Exit Do
       End If
    Loop Until arr(x, 1) <= 500
      sr = sr & "A" & x1 & ":D" & x & ","
    If Len(sr) > 255 Then
        sr = sr1
        Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 4
        sr = "A" & x1 & ":D" & x & ","
    End If
   End If
Next x
    Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 4
    MsgBox Timer - t
End Sub

Sub 数组方法3()
t = Timer
Dim arr
Dim x%, x1%
Dim sr As String, sr1 As String
Range("a:d").Interior.ColorIndex = xlNone
arr = Range("d2:d" & Range("d1").End(4).Row)
For x = 1 To UBound(arr)
  If arr(x, 1) > 500 Then
     sr1 = sr
     x1 = x + 1
    Do
       x = x + 1
       If x = UBound(arr) + 1 Then
          Exit Do
       End If
    Loop Until arr(x, 1) <= 500
      sr = sr & "A" & x1 & ":D" & x & ","
    If Len(sr) > 255 Then
        sr = sr1
    Application.Intersect(Range("a:d"), Range(Left(sr, Len(sr) - 1))).Interior.ColorIndex = 4
        sr = "A" & x1 & ":D" & x & ","
    End If
   End If
Next x
    Application.Intersect(Range("a:d"), Range(Left(sr, Len(sr) - 1))).Interior.ColorIndex = 4
    MsgBox Timer - t
End Sub
回复

使用道具 举报

发表于 2021-6-1 15:16 | 显示全部楼层
当连续800行的值多超过500是,中间会出现遗漏,
Sub szfa1()
清除颜色
Dim arr
Dim a, x As Integer
Dim sr, sr1 As String
arr = Range("d2:d" & Range("d65536").End(xlUp).Row + 1)
For a = 1 To UBound(arr)
If a = UBound(arr) And sr <> "" Then Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 8
If arr(a, 1) > 500 Then
sr1 = sr
sr = sr & "A" & a + 1 & ":D" & a + 1 & ","
If Len(sr) > 255 Then
sr = sr1
Range(Left(sr, Len(sr) - 1)).Interior.ColorIndex = 8
a = a - 1添加这行就没有遗漏了
sr = ""
End If
End If
Next
End Sub

回复

使用道具 举报

发表于 2021-9-12 10:02 | 显示全部楼层
数组方法1是有问题的A80:D80,没有变色
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 16:31 , Processed in 0.436388 second(s), 6 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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