根据提示的单元格值插入整行

所有，我有以下代码，但我需要知道如何修改它。 我需要一个提示或消息框问我，A列中的哪个值用于查找。 它应该在Sheet1列A中find相应的值，并将列A中的数据复制到AL到Sheet2。

这是我的代码：

Sub MM1() Dim Check As Range, r As Long, lastrow2 As Long, lastrow As Long Application.ScreenUpdating = False lastrow = Worksheets("Sheet1").UsedRange.Rows.Count lastrow2 = Worksheets("Sheet2").UsedRange.Rows.Count If lastrow2 = 1 Then lastrow2 = 0 For r = lastrow To 2 Step -1 If Range("E" & r).Value = "Yes" Then Rows(r).Cut Destination:=Worksheets("Sheet2").Range("A" & lastrow2 + 1) lastrow2 = lastrow2 + 1 Else: End If Next r Application.ScreenUpdating = True End Sub 

另外，这是代码的一个子集，它将search要插入的确切行。

Answer 1

您不需要通过sheet1中的行进行手动循环，只需使用VBA的本地Find函数即可。 此外，您目前没有获得用户input，可以通过InputBox实现。

有关代码的详细信息，请参阅注释。

---

此示例复制第一个匹配的数据 ：

 Sub MM1() Dim lastrowsheet2 As Long ' Use last cell in UsedRange for its row number, ' if row 1,2,... aren't used, then UsedRange will be shorter than you expect! With ThisWorkbook.Sheets("Sheet2").UsedRange lastrowsheet2 = .Cells(.Cells.Count).Row End With ' Get user input for a search term Dim userinput As String userinput = InputBox("Enter a value to search for.", "Column A Search") ' Search for value Dim findrange As Range Set findrange = ThisWorkbook.Sheets("Sheet1").Columns("A").Find(what:=userinput, lookat:=xlWhole, LookIn:=xlValues) If findrange Is Nothing Then MsgBox "No matching search results" Else lastrowsheet2 = lastrowsheet2 + 1 ' Copy values in found row to sheet 2, in new last row ThisWorkbook.Sheets("Sheet2").Range("A" & lastrowsheet2, "AL" & lastrowsheet2).Value _ = ThisWorkbook.Sheets("Sheet1").Range("A" & findrange.Row, "AL" & findrange.Row).Value End If End Sub 

---

此示例复制列中每个匹配的数据 ：

 Sub MM1() ' Speed improvements Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' Use last cell in UsedRange for its row number, ' if row 1,2,... aren't used, then UsedRange will be shorter than you expect! Dim lastrowsheet2 As Long With ThisWorkbook.Sheets("Sheet2").UsedRange lastrowsheet2 = .Cells(.Cells.Count).Row ' If sheet is completely empty, make sure data will be inserted on row 1 not 2 If lastrowsheet2 = 1 And .Cells(1).Value = "" Then lastrowsheet2 = 0 End With ' Get user input for a search term Dim userinput As String userinput = InputBox("Enter a value to search for.", "Column A Search") ' Search for value Dim findrange As Range Dim firstaddress As String Set findrange = ThisWorkbook.Sheets("Sheet1").Columns("A").Find(what:=userinput, lookat:=xlWhole, LookIn:=xlValues) If findrange Is Nothing Then MsgBox "No matching search results" Else firstaddress = findrange.Address Do lastrowsheet2 = lastrowsheet2 + 1 ' Copy values in found row to sheet 2, in new last row ThisWorkbook.Sheets("Sheet2").Range("A" & lastrowsheet2, "AL" & lastrowsheet2).Value _ = ThisWorkbook.Sheets("Sheet1").Range("A" & findrange.Row, "AL" & findrange.Row).Value ' Find next match Set findrange = ThisWorkbook.Sheets("Sheet1").Columns("A").FindNext(findrange) ' Loop until the Find has wrapped back around, or value not found any more Loop While Not findrange Is Nothing And findrange.Address <> firstaddress End If Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub