数据跟随的问题---

qiuzhuvba

附件下载: 0413.rar (2.78 KB, 下载次数: 3)

2014-4-13 23:11 上传

点击文件名下载附件

表格 求助1:
如图所示,

数据在B列..
C1为要统计跟随的数据,
D1为要跟随的行数/个数

C1=30,D1=1
执行VBA代码后

得到结果
33
25
16


若C1=30,D1=2,
那么执行VBA代码后
得到结果为
33
33
25
27
16
13
``````

表格 求助2:
如图所示....

数据在B列..
C1为要统计跟随的数据,
D1为要跟随的行数/个数
C1=02,D1=1
执行VBA代码后
得到结果
01 02 06 07 11
05 03 04 10 11
这里是 只要包含有02 就取下一行的数据,若下一行没数据了就不再取.

qiuzhuvba

蓝桥玄霜

1. Sub 按钮1_单击()
   
2. Dim Arr, i&, sz, gs, j&, aa
   
3. Dim d, k, t
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Sheet1.Activate
   
6. [g:g].ClearContents
   
7. sz = [c2].Value: gs = [d2].Value
   
8. Arr = [b2].CurrentRegion
   
9. For i = 1 To UBound(Arr) - gs
   
10.     If Arr(i, 1) = sz Then d(Arr(i, 1)) = d(Arr(i, 1)) & i & ","
    
11. Next
    
12. k = d.keys: t = d.items: n = 2
    
13. For i = 0 To UBound(k)
    
14.     t(i) = Left(t(i), Len(t(i)) - 1)
    
15.     If InStr(t(i), ",") Then
    
16.         aa = Split(t(i), ",")
    
17.         For j = 0 To UBound(aa)
    
18.             Cells(n, 7).Resize(gs, 1) = Cells(aa(j) + 2, 2).Resize(gs, 1).Value
    
19.             n = n + gs
    
20.         Next
    
21.     Else
    
22.         [g2].Resize(gs, 1) = Cells(t(i) + 2, 2).Resize(gs, 1).Value
    
23.     End If
    
24. Next
    
25. End Sub
    
26. Sub lqxs()
    
27. Dim Arr, i&, sz, gs, n&
    
28. Sheet2.Activate
    
29. [g:g].ClearContents
    
30. sz = [c1].Value: gs = [d1].Value
    
31. Arr = [b1].CurrentRegion
    
32. For i = 1 To UBound(Arr) - gs
    
33.     If InStr(Arr(i, 1), sz) Then
    
34.         n = n + 1
    
35.         Cells(n, 7).Resize(gs, 1) = Cells(i + 1, 2).Resize(gs, 1).Value
    
36.     End If
    
37. Next
    
38. End Sub
    

复制代码

蓝桥玄霜

请见附件。

qiuzhuvba

例如
C1=10,D1=2,时
结果应该为
01 02 06 07 11
05 03 04 10 11
01 05 06 08 09
03 04 07 08 09
02 03 04 06 11

qiuzhuvba

蓝桥老师好..
刚测试了代码...
发现 我原先的附件 数据例子错误了..
数据源是从B1开始的..
其它参数是C1,D1的 ,,原先大意了 设置在C2,D2了..
重新上传附件 和例子



Book0414.rar (6.34 KB, 下载次数: 6)

2014-4-14 09:18 上传

点击文件名下载附件

qiuzhuvba

蓝桥玄霜 发表于 2014-4-14 09:01

蓝桥老师好..

我重新传了 附件...
原先的附件 有错误

qiuzhuvba

中午好  各位老师

qiuzhuvba

蓝桥老师的 (表格2)代码 把重复的 去掉了...

实际上 不需要去重复了

Sub lqxs() 说的是这个VBA

蓝桥玄霜

1.     Sub 按钮1_单击()
   
2.     Dim Arr, i&, sz, gs, j&, aa
   
3.     Dim d, k, t
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Sheet1.Activate
   
6.     [g:g].ClearContents
   
7.     sz = [c1].Value: gs = [d1].Value
   
8.     Arr = [b1].CurrentRegion
   
9.     For i = 1 To UBound(Arr) - gs
   
10.         If Arr(i, 1) = sz Then d(Arr(i, 1)) = d(Arr(i, 1)) & i & ","
    
11.     Next
    
12.     k = d.keys: t = d.items: n = 1
    
13.     For i = 0 To UBound(k)
    
14.         t(i) = Left(t(i), Len(t(i)) - 1)
    
15.         If InStr(t(i), ",") Then
    
16.             aa = Split(t(i), ",")
    
17.             For j = 0 To UBound(aa)
    
18.                 Cells(n, 7).Resize(gs, 1) = Cells(aa(j) + 1, 2).Resize(gs, 1).Value
    
19.                 n = n + gs
    
20.             Next
    
21.         Else
    
22.             [g1].Resize(gs, 1) = Cells(t(i) + 2, 2).Resize(gs, 1).Value
    
23.         End If
    
24.     Next
    
25.     End Sub
    
26.     Sub lqxs()
    
27.     Dim Arr, i&, sz, gs, n&
    
28.     Sheet2.Activate
    
29.     [g:g].ClearContents
    
30.     sz = [c1].Value: gs = [d1].Value: n = 1
    
31.     Arr = [b1].CurrentRegion
    
32.     For i = 1 To UBound(Arr) - gs
    
33.         If InStr(Arr(i, 1), sz) Then
    
34.             Cells(n, 7).Resize(gs, 1) = Cells(i + 1, 2).Resize(gs, 1).Value
    
35.             n = Cells(Rows.Count, 7).End(xlUp).Row + 1
    
36.         End If
    
37.     Next
    
38.     End Sub
    

复制代码