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

guogongyi

这个宏现在只能将“表二”工作表中带“今天、公司、家”等等一次性复制到“新建”工作表中。现在我想要一个能以“表一”A列单元格为关键词（不一定几行，这样好改关键词），一次性将“表二”中含有关键词的行剪切（要剪切，剪切后不留空行）到“新建”工作表中。谢谢

最佳答案

月排行榜 / 总排行榜

兰色幻想

2013-8-6 08:07

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

没有哪位大师能做吗？

guogongyi

大侠都休息了

guogongyi

帮帮忙啊

武林长风

正想学习这个

guogongyi

这个我觉得很有用的

武林长风

guogongyi 发表于 2013-8-5 07:33
这个我觉得很有用的

这个的确很有用，可是高手在哪里呢？

兰色幻想

Sub 今天()
On Error Resume Next
Dim arr, sr As String
arr = Sheets("表一").Range("a2:A" & Sheets("表一").Range("a2").End(xlDown).Row)
For j = 1 To UBound(arr)
sr = sr & "-" & arr(j, 1)
Next j
m = Sheets("表二").Cells.Find("*", , , , , xlPrevious).Row
For i = 1 To m
  For n = 1 To Rows(i).Find("*", , , , , xlPrevious).Column
If InStr(sr, Cells(i, n)) > 0 Then
    x = Sheets("新建").Cells.Find("*", , , , , xlPrevious).Row
    Rows(i).Copy Sheets("新建").Range("a" & x + 1)
   GoTo 1
End If
Next n
1
Next i
End Sub

guogongyi

我看了一下，这个宏不对啊，是整个把表二复制到“新建”工作表了，与表一A列的关键词没有关系啊。
现在我想要一个能以“表一”A列单元格为关键词（不一定几行，这样好改关键词），一次性将“表二”中含有关键词的行剪切（要剪切，剪切后不留空行）到“新建”工作表中。谢谢

兰色幻想

Sub 今天()
On Error Resume Next
Dim arr, sr As String
arr = Sheets("表一").Range("a2:A" & Sheets("表一").Range("a2").End(xlDown).Row)

m = Sheets("表二").Cells.Find("*", , , , , xlPrevious).Row
For i = 1 To m
  For n = 1 To Sheets("表二").Rows(i).Find("*", , , , , xlPrevious).Column
  q = Sheets("表二").Cells(i, n)
k = 0
For j = 1 To UBound(arr)
  If InStr(q, arr(j, 1)) > 0 Then
    k = 1
    Exit For
  End If
Next j
If k = 1 Then
    x = Sheets("新建").Cells.Find("*", , , , , xlPrevious).Row
    Sheets("表二").Rows(i).Copy Sheets("新建").Range("a" & x + 1)
   GoTo 1
End If
Next n
1
Next i
End Sub