请大神看看，如何把符合条件的内容，复制到另一张表

长笑123

请大神看看能用VBA实现吗？

skyzxh

VBA无所不能，应该可以完成。。。。。。。。。。。。。。。。。。。。

yeminqiang

1. Sub cdsr()
   
2.     Dim arr, R&, C&, i&, j&, s, k%
   
3.     Dim d As Object
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Sheet2.UsedRange
   
6.     Application.ScreenUpdating = False
   
7.     With Sheets("排程")
   
8.         For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row  Step 10
   
9.             .Cells(i + 1, 1).Resize(9, 12).ClearContents
   
10.         Next
    
11.     End With
    
12.     On Error Resume Next '数据不规范,6T1、6T2所在的单元格有空格，已删除.但还是保留此代码
    
13.     For i = 4 To UBound(arr)
    
14.         For j = 7 To UBound(arr, 2)
    
15.             If arr(i, j) = "●" Then
    
16.                 d(arr(2, j)) = d(arr(2, j)) + 1
    
17.                 k = d(arr(2, j))
    
18.                 s = Replace(arr(2, j), "T", "T-")
    
19.                 R = Sheet1.UsedRange.Find(s).Row
    
20.                 C = Sheet1.UsedRange.Find(s).Column
    
21.                 If k <= 9 Then '注意K的值一定不能够大于18，即每个50T-2下面的18个空格一定要能够装满所有●标记的图号
    
22.                 Sheet1.Cells(R, C).Offset(k, 0) = arr(i, 2)
    
23.                     ElseIf k <= 18 Then
    
24.                 Sheet1.Cells(R, C + 1).Offset(k - 9, 0) = arr(i, 2)
    
25.                 End If
    
26.             End If
    
27.         Next
    
28.     Next
    
29.     Application.ScreenUpdating = True
    
30. End Sub
    

复制代码

yeminqiang

排程.zip (28.04 KB, 下载次数: 32)

2016-6-5 11:13 上传

点击文件名下载附件

jin200808

精妙的VBA用法，感谢分享。

长笑123

yeminqiang 发表于 2016-6-5 11:12

谢谢老师，出差了1个星期，现在下下来学习中，感谢帮助！！！