[已解决]查找剪切工作表中的行到“新建”工作表中

guogongyi

兰色幻想 发表于 2013-8-5 23:25
Sub 今天()
On Error Resume Next
Dim arr, sr As String

谢谢老师，已经能用了。但有以现在是这样：[tr] [/tr]

没有关键词或只有一个时，会去空行复制全部；关键词之间不能有空行，有空行时，空行下面的关键词不复制；其他正常。辛苦老师完善。

兰色幻想

1. Sub 今天()
   
2. On Error Resume Next
   
3. Dim arr, sr As String
   
4. arr = Sheets("表一").Range("a2:a" & Sheets("表一").Range("a65535").End(xlUp).Row + 1)
   
5. If UBound(arr) = 0 Then Exit Sub
   
6. m = Sheets("表二").Cells.Find("*", , , , , xlPrevious).Row
   
7. For i = 1 To m
   
8.   For n = 1 To Sheets("表二").Rows(i).Find("*", , , , , xlPrevious).Column
   
9.   q = Sheets("表二").Cells(i, n)
   
10. k = 0
    
11. For j = 1 To UBound(arr)
    
12.   If arr(j, 1) <> "" And InStr(q, arr(j, 1)) > 0 Then
    
13.     k = 1
    
14.     Exit For
    
15.   End If
    
16. Next j
    
17. If k = 1 Then
    
18.     x = Sheets("新建").Cells.Find("*", , , , , xlPrevious).Row
    
19.     Sheets("表二").Rows(i).Copy Sheets("新建").Range("a" & x + 1)
    
20.    GoTo 1
    
21. End If
    
22. Next n
    
23. 1
    
24. Next i
    
25. End Sub

复制代码

guogongyi

兰色幻想 发表于 2013-8-6 08:07

谢谢，非常好，辛苦了

guogongyi

兰色幻想 发表于 2013-8-6 08:07

现在这个是复制，能把这个改成删除吗？