[已解决]请编写VBA代码计算出如下中的数？谢谢！

qingmei

最佳答案

月排行榜 / 总排行榜

grf1973

2015-11-7 19:56

1. Sub tt()
   
2.     Dim st As Range
   
3.     Set st = Application.InputBox("请输入单元格范围", "选择单元格区域", , , , , , 8)
   
4.     arr = st           '[c10:c27]
   
5.     ReDim brr(1 To UBound(arr), 1 To 1)
   
6.     For i = 1 To UBound(arr) - 1
   
7.         x = arr(i, 1)
   
8.         If Len(x) > 0 Then
   
9.             xb = 0        '空值个数
   
10.             For j = i + 1 To UBound(arr)
    
11.                 y = arr(j, 1)
    
12.                 If Len(y) = 0 Then xb = xb + 1: GoTo nj
    
13.                 If x = 0 Then
    
14.                     If y <> 0 Then Exit For
    
15.                 Else
    
16.                     If x * y <= 0 Then Exit For
    
17.                 End If
    
18. nj:         Next
    
19.             p = j - 1: gs = p - i + 1 - xb        '连续个数（i到(j-1)，去掉空值
    
20.             If gs > 0 Then
    
21.                 n = n + 1
    
22.                 brr(n, 1) = IIf(x >= 0, gs, -gs)
    
23.             End If
    
24.             i = p
    
25.         End If
    
26.     Next
    
27.     If n > 0 Then
    
28.         [e18:e1000].ClearContents
    
29.         [e18].Resize(n, 1) = brr
    
30.     End If
    
31. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub tt()
   
2.     Dim st As Range
   
3.     Set st = Application.InputBox("请输入单元格范围", "选择单元格区域", , , , , , 8)
   
4.     arr = st           '[c10:c27]
   
5.     ReDim brr(1 To UBound(arr), 1 To 1)
   
6.     For i = 1 To UBound(arr) - 1
   
7.         x = arr(i, 1)
   
8.         If Len(x) > 0 Then
   
9.             xb = 0        '空值个数
   
10.             For j = i + 1 To UBound(arr)
    
11.                 y = arr(j, 1)
    
12.                 If Len(y) = 0 Then xb = xb + 1: GoTo nj
    
13.                 If x = 0 Then
    
14.                     If y <> 0 Then Exit For
    
15.                 Else
    
16.                     If x * y <= 0 Then Exit For
    
17.                 End If
    
18. nj:         Next
    
19.             p = j - 1: gs = p - i + 1 - xb        '连续个数（i到(j-1)，去掉空值
    
20.             If gs > 0 Then
    
21.                 n = n + 1
    
22.                 brr(n, 1) = IIf(x >= 0, gs, -gs)
    
23.             End If
    
24.             i = p
    
25.         End If
    
26.     Next
    
27.     If n > 0 Then
    
28.         [e18:e1000].ClearContents
    
29.         [e18].Resize(n, 1) = brr
    
30.     End If
    
31. End Sub
    

复制代码

grf1973

.................

金樽空对月

1. Sub mysums()
   
2. On Error Resume Next
   
3. Dim x, y, m, arr, k, arr1(), ar(1 To 10000)
   
4. Dim rg As Range, rng As Range
   
5. Set rng = Selection
   
6. If rng <> "" Then
   
7.   arr = rng
   
8. Else
   
9.   MsgBox "请选择要计算的数据区域", vbInformation, "系统提示"
   
10.   Exit Sub
    
11. End If
    
12. ReDim arr1(1 To UBound(arr) + 1, 1 To 1)
    
13. Set rg = Application.InputBox("请选择存放结果区域的首单元格", "选择目标区域", Type:=8)
    
14. For x = 1 To UBound(arr)
    
15.   If arr(x, 1) > 0 Then
    
16.      arr1(x, 1) = "A"
    
17.   ElseIf arr(x, 1) = 0 Then
    
18.      arr1(x, 1) = "B"
    
19.   Else
    
20.      arr1(x, 1) = "C"
    
21.   End If
    
22. Next x
    
23. For y = 1 To UBound(arr1) - 1
    
24.    If arr1(y, 1) = arr1(y + 1, 1) Then
    
25.      m = m + 1
    
26.    Else
    
27.      k = k + 1
    
28.      If arr1(y, 1) = "C" Then
    
29.        ar(k) = "-" & m + 1
    
30.      Else
    
31.        ar(k) = m + 1
    
32.      End If
    
33.      m = 0
    
34.    End If
    
35. Next y
    
36. rg.Resize(UBound(ar)) = Application.Transpose(ar)
    
37. End Sub

复制代码

我也来一个

金樽空对月

这是附件。

qingmei

grf1973 发表于 2015-11-7 19:56
.................

非常感谢！

qingmei

金樽空对月 发表于 2015-11-7 23:53
这是附件。

非常感谢！