Excel Vba：创建循环以检查 A 列中的值是否匹配并将所有行复制到新电子表格

Excel Vba: Creating loop that checks if the values in column A matches and copy all the rows to a new spreadsheet

提问by Developous

I need to select all the rows in column A that have the same the value and paste them to a new spreadsheet named with the copied name.

我需要选择 A 列中具有相同值的所有行，并将它们粘贴到以复制名称命名的新电子表格中。

In the example picture when I run macro and input value Banana I should get all the rows that contain banana in column A.

在示例图片中，当我运行宏并输入值 Banana 时，我应该得到 A 列中包含香蕉的所有行。

I found following vba code from the internet and tried to modify it to my needs but I'm stuck:

我从互联网上找到了以下 vba 代码，并试图根据我的需要对其进行修改，但我被卡住了：

Sub LookForAllSameValues()

   Dim LSearchRow As Integer
   Dim LCopyToRow As Integer

   On Error GoTo Err_Execute

   'Start search in row 4
   LSearchRow = 2

   'Start copying data to row 2 in Sheet2 (row counter variable)
   LCopyToRow = 2

   Uname = InputBox("Test")
   ActiveWorkbook.Worksheets.Add.Name = Uname

   While Len(Range("A" & CStr(LSearchRow)).Value) > 0

      'If value in column E = "Mail Box", copy entire row to Sheet2
      If Range("A" & CStr(LSearchRow)).Value = Uname Then

         'Select row in Sheet1 to copy
         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
         Selection.Copy

         'Paste row into Sheet2 in next row

         Sheets(Uname).Select
         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
         ActiveSheet.Paste

         'Move counter to next row
         LCopyToRow = LCopyToRow + 1

         'Go back to Sheet1 to continue searching
         Sheets("Sheet1").Select

      End If

      LSearchRow = LSearchRow + 1

   Wend

   'Position on cell A3
   Application.CutCopyMode = False
   Range("A3").Select

   MsgBox "All matching data has been copied."

   Exit Sub

Err_Execute:
   MsgBox "An error occurred."

End Sub

This code almost works. It asks user to input string to search and then it creates a new worksheet named as this one. The problem lies in the loop, I debugged the code and for some reason it just skips copy paste loop

这段代码几乎有效。它要求用户输入字符串进行搜索，然后创建一个名为 this 的新工作表。问题出在循环中，我调试了代码，出于某种原因，它只是跳过了复制粘贴循环

How do I get the loop working?

我如何让循环工作？

Output when the code is run:

代码运行时的输出：

回答by Aiken

I'm assuming you're testing this on the data shown above.

我假设您正在对上面显示的数据进行测试。

Your code states that LSearch Row = 2and therefore your search will begin in cell A2. I'd therefore assume your loop is never executing because Len(Range("A2"))equals 0(the cell is empty) and the loop immediately exits. This also means that if any cell in column A is empty the loop will end there even if there is more data below it.

您的代码指出，LSearch Row = 2因此您的搜索将从单元格 A2 开始。因此，我假设您的循环永远不会执行，因为Len(Range("A2"))等于0（单元格为空）并且循环立即退出。这也意味着如果 A 列中的任何单元格为空，即使其下方有更多数据，循环也会在那里结束。

Instead try using a For..Nextloop as shown below which will run from row 2 to the last used row in the active sheet, regardless of the cell contents.

而是尝试使用For..Next如下所示的循环，该循环将从第 2 行运行到活动工作表中最后使用的行，而不管单元格内容如何。

Public Sub FindAndCreateNew()
    Dim strFind As String
    Dim i As Long, j As Long
    Dim wsFind As Worksheet
    Dim wsPaste As Worksheet

    'Get value to search for
    strFind = InputBox("Test")

    'Create object reference to the current worksheet
    Set wsFind = ActiveSheet

    'Create a new worksheet with object reference and then rename it
    Set wsPaste = Worksheets.Add
    wsPaste.Name = strFind

    'Paste starting at row 2 in wsPaste
    j = 2

    'Start searching from row 2 of wsFind, continue to end of worksheet
    For i = 2 To wsFind.UsedRange.Rows.Count
        If wsFind.Range("A" & i) = strFind Then
            'Copy row i of wsFind to row j of wsPaste then increment j
            wsFind.Range(i & ":" & i).Copy Destination:=wsPaste.Range(j & ":" & j)
            j = j + 1
        End If
    Next i
End Sub

P.S. It's also worth noting that the use of .Selectis generally avoidable and it can slow the program down considerably as well as making it less readable. For example this:

PS 还值得注意的是，使用.Select通常是可以避免的，它会大大减慢程序的速度并降低其可读性。例如这个：

'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy

Could be represented with just one statement as below:

可以只用一个语句来表示，如下所示：

'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Copy

回答by L42

As commented, try this:

正如评论的那样，试试这个：

Sub test()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim rng As Range
    Dim uname As String

    Set sh1 = Sheet1: uname = InputBox("Input")
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    If Len(uname) = 0 Then MsgBox "Invalid input": Exit Sub
    Set sh2 = ThisWorkbook.Sheets.Add(after:= _
        ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    On Error Resume Next
    sh2.Name = uname: If Err.Number <> 0 Then MsgBox "Data already copied": _
        sh2.Delete: Exit Sub
    On Error GoTo 0

    With sh1
        .AutoFilterMode = False
        Set rng = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
        rng.AutoFilter 1, uname
        On Error Resume Next
        rng.SpecialCells(xlCellTypeVisible).EntireRow.Copy sh2.Range("A1")
        If Err.Number <> 0 Then MsgBox "Data not found" _
            Else MsgBox "All matching data has been copied"
        .AutoFilterMode = False
        On Error GoTo 0
    End With

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub