设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 求连续0之间单个0和不等于0的个数
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2030|回复: 4

[已解决]求连续0之间单个0和不等于0的个数

[复制链接]
hhaa999
发表于 2012-12-20 10:17 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
连续0之间单个0和不等于0的个数
最佳答案
月排行榜 / 总排行榜
liuguansky
2012-12-21 10:10
  1. Sub justtest()
  2.     Dim Arr(), i&, k&, Ar&(1 To 10000, 1 To 3), S&
  3.     k = -1
  4.     Arr = Range([b2], [b2].End(4)).Value
  5.     For i = 1 To UBound(Arr) - 1
  6.         If Arr(i, 1) = 0 Then
  7.             j = i + 1
  8.             Do While Arr(j, 1) = 0
  9.                 j = j + 1
  10.             Loop
  11.             If j - i > 1 Then
  12.                 k = k + 1: i = j - 1
  13.                 If k > 0 Then Ar(k, 1) = i
  14.             Else
  15.                 GoTo 100
  16.             End If
  17.         Else
  18. 100
  19.             If k > -1 Then
  20.                 If Arr(i, 1) > 0 Then
  21.                     Ar(k + 1, 2) = Ar(k + 1, 2) + 1
  22.                 Else
  23.                     Ar(k + 1, 3) = Ar(k + 1, 3) + 1
  24.                 End If
  25.             End If
  26.         End If
  27.     Next i
  28.     [d4].Resize(k, 3) = Ar
  29. End Sub
复制代码

Book10.rar

7.86 KB, 下载次数: 25

评分

参与人数 1 +3 收起 理由
hoogle + 3 我汗，这个题看着简单，实际情况分析下来挺.

查看全部评分

excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
hoogle
发表于 2012-12-20 19:51 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Sub hoogle()
  2. Dim arr, i, brr(1 To 10, 1 To 2), temp(), t
  3. For i = 1 To 10
  4.     For j = 1 To 2
  5.         brr(i, j) = 0
  6.     Next
  7. Next
  8. Range("e4").Resize(100, 2).ClearContents
  9. arr = Range("a2").CurrentRegion
  10. ReDim temp(1 To UBound(arr))
  11. For i = 1 To UBound(arr)
  12.     If i + 1 < UBound(arr) Then
  13.         If arr(i, 2) = 0 And arr(i + 1, 2) = 0 Then
  14.             temp(i) = "a"
  15.             temp(i + 1) = "a"
  16.         ElseIf temp(i) <> "a" Then
  17.             temp(i) = arr(i, 2)
  18.         End If
  19.     ElseIf i = UBound(arr) Then
  20.         If temp(i - 1) = "a" And arr(i, 2) = 0 Then
  21.             temp(i) = "a"
  22.         Else
  23.             temp(i) = arr(i, 2)
  24.         End If
  25.     End If
  26. Next
  27. For i = 1 To UBound(arr)
  28.     If temp(i) = "a" And i + 1 <= UBound(arr) Then
  29.         If temp(i + 1) <> "a" Then
  30.             t = t + 1
  31.         End If
  32.     End If
  33.         If temp(i) <> "a" And t >= 1 Then
  34.             If temp(i) > 0 Then
  35.                 brr(t, 1) = brr(t, 1) + 1
  36.             ElseIf temp(i) = 0 Then
  37.                 brr(t, 2) = brr(t, 2) + 1
  38.             End If
  39.         End If
  40. Next
  41. If temp(UBound(arr)) <> "a" Then t = t - 1
  42. Range("e4").Resize(t, 2) = brr
  43. End Sub
复制代码
Book10.zip (14 KB, 下载次数: 2)
回复

使用道具 举报

发表于 2012-12-20 21:02 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
  1. Sub lqxs()
  2. Dim Arr, i&, r%, Arr1(), n&, j&, ks, js
  3. Dim m&, a, b
  4. Sheet1.Activate
  5. [d4:f100].ClearContents
  6. Arr = [a1].CurrentRegion
  7. For i = 2 To UBound(Arr)
  8.     If Arr(i, 2) = 0 Then
  9.         n = n + 1
  10.     Else
  11.         If n > 1 Then
  12.             r = r + 1
  13.             ReDim Preserve Arr1(1 To 2, 1 To r)
  14.             Arr1(1, r) = i - 1
  15.             Arr1(2, r) = n
  16.         End If
  17.         n = 0
  18.     End If
  19. Next
  20. If n > 1 Then
  21.     r = r + 1
  22.     ReDim Preserve Arr1(1 To 2, 1 To r)
  23.     Arr1(1, r) = i - 1
  24.     Arr1(2, r) = n
  25. End If
  26. If r < 2 Then Exit Sub
  27. m = 3
  28. For i = 1 To r
  29.     a = 0: b = 0
  30.     js = Arr1(1, i + 1) - Arr1(2, i + 1)
  31.     ks = Arr1(1, i) + 1
  32.     For j = ks To js
  33.         If Arr(j, 2) = 0 Then
  34.             a = a + 1
  35.         Else
  36.             b = b + 1
  37.         End If
  38.     Next
  39.     m = m + 1
  40.     Cells(m, 4) = js + 1
  41.     Cells(m, 5) = b
  42.     Cells(m, 6) = a
  43. Next
  44. End Sub
复制代码
回复

使用道具 举报

发表于 2012-12-21 10:10 | 显示全部楼层    本楼为最佳答案   
  1. Sub justtest()
  2.     Dim Arr(), i&, k&, Ar&(1 To 10000, 1 To 3), S&
  3.     k = -1
  4.     Arr = Range([b2], [b2].End(4)).Value
  5.     For i = 1 To UBound(Arr) - 1
  6.         If Arr(i, 1) = 0 Then
  7.             j = i + 1
  8.             Do While Arr(j, 1) = 0
  9.                 j = j + 1
  10.             Loop
  11.             If j - i > 1 Then
  12.                 k = k + 1: i = j - 1
  13.                 If k > 0 Then Ar(k, 1) = i
  14.             Else
  15.                 GoTo 100
  16.             End If
  17.         Else
  18. 100
  19.             If k > -1 Then
  20.                 If Arr(i, 1) > 0 Then
  21.                     Ar(k + 1, 2) = Ar(k + 1, 2) + 1
  22.                 Else
  23.                     Ar(k + 1, 3) = Ar(k + 1, 3) + 1
  24.                 End If
  25.             End If
  26.         End If
  27.     Next i
  28.     [d4].Resize(k, 3) = Ar
  29. End Sub
复制代码
回复

使用道具 举报

zhoucs00
发表于 2012-12-21 15:36 | 显示全部楼层
hoogle 发表于 2012-12-20 19:51

我杂看不懂题目是什么意思。。
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-4-29 05:06 , Processed in 0.271755 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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