[已解决]求个vba

lkjhuy

123.rar (106.93 KB, 下载次数: 19)

2014-1-27 22:31 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

xdragon

2014-1-27 22:51

1. Sub Co()
   
2.   Dim arr(), i%, j&, re(1 To 1, 1 To 10)
   
3.   ReDim arr(1 To Sheets.Count)
   
4.   For i = 1 To UBound(arr)
   
5.     arr(i) = Sheets(CStr(i)).Range("N2:CL2").Value
   
6.     For j = 1 To UBound(arr(i), 2)
   
7.       If arr(i)(1, j) >= 1 And arr(i)(1, j) <= 10 Then re(1, arr(i)(1, j)) = re(1, arr(i)(1, j)) + 1
   
8.     Next
   
9.     Sheets(CStr(i)).Range("H1:Q1") = re
   
10.   Next
    
11.   For i = 2 To 4
    
12.     [A2].Offset(0, i) = Sheets(CStr(i)).[b2].Value
    
13.   Next
    
14. End Sub

复制代码

不知是否符合楼主的要求。看看。。

跳转到最佳答案楼层

xdragon

1. Sub Co()
   
2.   Dim arr(), i%, j&, re(1 To 1, 1 To 10)
   
3.   ReDim arr(1 To Sheets.Count)
   
4.   For i = 1 To UBound(arr)
   
5.     arr(i) = Sheets(CStr(i)).Range("N2:CL2").Value
   
6.     For j = 1 To UBound(arr(i), 2)
   
7.       If arr(i)(1, j) >= 1 And arr(i)(1, j) <= 10 Then re(1, arr(i)(1, j)) = re(1, arr(i)(1, j)) + 1
   
8.     Next
   
9.     Sheets(CStr(i)).Range("H1:Q1") = re
   
10.   Next
    
11.   For i = 2 To 4
    
12.     [A2].Offset(0, i) = Sheets(CStr(i)).[b2].Value
    
13.   Next
    
14. End Sub

复制代码

不知是否符合楼主的要求。看看。。

风林火山

1. Sub test()
   
2. Dim k%, i%, n%, arr
   
3. arr = Range("n2:cl2")
   
4. 
   
5. For i = 1 To 10
   
6.     For k = 1 To UBound(arr, 2)
   
7.        If arr(1, k) = i Then Cells(1, 7 + i) = Cells(1, 7 + i) + 1
   
8.     Next k
   
9. Next i
   
10. [c2] = Sheets(2).[b2]: [d2] = Sheets(3).[b2]: [e2] = Sheets(4).[b2]
    
11. 
    
12. End Sub

复制代码