悬赏求助（五）最佳答案奖金200元（因长时间没有有效答案，赏金加倍）

准提部林

不確定你的版本可不可用!

1. Sub TEST()
   
2. Dim R&, N%, M&, C%, Cn%, Rn%, i&, j&
   
3. Call ClearAll
   
4. Cn = [AH2]: Rn = [AH3]
   
5. R = [L65536].End(3).Row
   
6. Application.ScreenUpdating = False
   
7. For i = 1 To 20
   
8. For j = 1 To R + 1
   
9. 　　On Error Resume Next
   
10. 　　C = [L1].Cells(j, i - Cn).Resize(1, Cn).Interior.ColorIndex
    
11. 　　On Error GoTo 0
    
12. 　　If C <> xlNone Or j > R Then
    
13. 　　　　If N >= Rn Then [L1].Cells(M, i).Resize(N).Copy [AK1].Cells(M, i)
    
14. 　　　　N = 0: GoTo 101
    
15. 　　End If
    
16. 　　N = N + 1: C = 1: If N = 1 Then M = j
    
17. 101: Next j
    
18. Next i
    
19. End Sub
    
20. 
    
21. Sub ClearAll()
    
22. With [AK:BD]: .ClearContents: .Interior.ColorIndex = xlNone: End With
    
23. End Sub

复制代码

　
Xl0000330.rar (56.24 KB, 下载次数: 2)

2018-3-1 20:27 上传

点击文件名下载附件

　
　

hmfs1107

七夕、 发表于 2018-3-1 09:15
已更改,请再测试

牛