付费做代码

mmc998

Book筛选组合.rar (1.71 MB, 下载次数: 149)

2018-11-16 21:44 上传

点击文件名下载附件

excelvlookup

别人写个代码也要几十分钟，你不可以用同样的时间来完善你的说明吗？不说清楚，付费也没用。说清楚了，你不用付费。

liulang0808

楼主结合附件，举例描述清楚吧

mmc998

1085091193

chxw68

excelvlookup 发表于 2018-11-16 22:18
别人写个代码也要几十分钟，你不可以用同样的时间来完善你的说明吗？不说清楚，付费也没用。说清楚了，你不 ...

说的很有道理！

mmc998

Book筛选组合.rar (1.71 MB, 下载次数: 62)

2018-11-17 10:11 上传

点击文件名下载附件

HTDZ-XUAN

还是未能知道你想表达什么意思

sayhi95

楼主听没听过1360亿的新闻消息？

chxw68

1. Sub test()
   
2.   Dim r&, i&, j&, c&
   
3.   Dim arr, brr, drr() As Integer
   
4.   Application.ScreenUpdating = False
   
5.   Application.DisplayAlerts = False
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a8:k" & r)
   
9.     brr = .Range("o1:s6")
   
10.     ReDim crr(1 To UBound(arr), 1 To UBound(brr, 2))
    
11.     For i = 1 To UBound(arr) Step 4
    
12.       For k = 1 To 3
    
13.         ReDim drr(1 To 33)
    
14.         For j = 1 To UBound(arr, 2)
    
15.           drr(arr(i + k - 1, j)) = drr(arr(i + k - 1, j)) + 1
    
16.         Next
    
17.         For y = 1 To UBound(brr, 2)
    
18.           frr = drr
    
19.           For x = 1 To UBound(brr)
    
20.             frr(brr(x, y)) = frr(brr(x, y)) + 1
    
21.           Next
    
22.           s = 0
    
23.           For q = 1 To UBound(frr)
    
24.             If frr(q) = 2 Then
    
25.               s = s + 1
    
26.             End If
    
27.           Next
    
28.           crr(i + k - 1, y) = s
    
29.         Next
    
30.       Next
    
31.     Next
    
32.     .Range("o8").Resize(UBound(crr), UBound(crr, 2)) = crr
    
33.   End With
    
34. End Sub
    

复制代码

chxw68

详见附件。