搜索一個特定的單詞並將其複製到另一個工作表

Question

我有一個電子表格，其中包含A-P和第1到2016行（並且仍在不斷增長）的列。我正在尋找一種簡單的方法來搜索電子表格中的特定單詞，例如「間隙」，並將包含單詞「間隙」的行復制到Sheet2。我想如果它可以使用一個框，我可以根據需要搜索不同的東西。

我不希望電子表格變得更小（這是一個行動項目列表，我需要它搜索，直到它到達一個空行）。

我該怎麼做？

Answer 1

'all variables must be declared  
Option Explicit 
Sub CopyData() 

'this variable holds a search phrase, declared as variant as it might be text or number 
Dim vSearch As Variant 
'these three variables are declared as long, technically the loop might exceed 32k (integer) therefore it is safer to use long 
Dim i As Long 
Dim k As Long 
Dim lRowToCopy As Long 

'the macro prompts a user to enter the search phrase 
vSearch = InputBox("Search") 
'varialbe i initially declared as 1 - macro starts calculations from the 1st row 
i = 1 
'macro will loop until it finds a row with no records 
'I called a standard XLS function COUNTA to count the number of non-blank cells 
'if the macro finds a row with no records it quits the loop 
Do Until WorksheetFunction.CountA(Sheets("Main").Rows(i)) = 0 

'here I let the macro to continue its run despite a possible errors (explanation below) 
    On Error Resume Next 
    lRowToCopy = 0 
'if Find method finds no value VBA returns an error, this is why I allowed macro to run despite that. In case of error variable lRowToCopy keeps 0 value 
'if Find method finds a searched value it assigns the row number to var lRowToCopy 
    lRowToCopy = Sheets("Main").Rows(i).Find(What:=vSearch, LookIn:=xlValues,  LookAt:=xlPart, SearchOrder:=xlByRows).Row 
'here we allow macro to disiplay error messages 
    On Error GoTo 0 

'if var lRowToCopy does not equal to 0 that means a row with a searched value has been found 
    If lRowToCopy > 0 Then 

    'this loop looks for the first blank row in 2nd sheet, I also used COUNTA to find absolutely empty row 
    For k = 1 To Sheets("ToCopy").Rows.Count 

     'when the row is found, the macro performs copy-paste operation 
     If WorksheetFunction.CountA(Sheets("ToCopy").Rows(k)) = 0 Then 

      Sheets("Main").Rows(i).Copy 
      Sheets("ToCopy").Select 
      Rows(k).Select 
      ActiveSheet.Paste 
      'do not forget to exit for loop as it will fill all empty rows in 2nd sheet 
      Exit For 

     End If 
    Next k 

    End If 

i = i + 1 
Loop 

End Sub