копировать и вставлять несколько строк, используя некоторые условия

Question

Я должен написать макрос для , условно скопировать определенные строки.Если пользователь вводит какое-то число в любую пустую ячейку, скажем, A55, это число будет соответствовать столбцу A (или A1), если число найдено в A1, тогда должна быть выбрана вся строка.И если число найдено в нескольких местах в столбце A, то оно должно скопировать все строки и вставить их в новый лист, скажем sheet2.

Вот мой код, который получает доступ только ко всем строкам, в которых найден номер A55, и я не уверен, как скопировать выбранные строки:

copyandpaste() 
    Dim x As String 
    Dim matched As Integer 
    Range("A1").Select 
    x = Worksheets("Sheet1").Range("A55") 
    matched = 0 
         Do Until IsEmpty(ActiveCell) 
        If ActiveCell.Value = x Then 
            matched = matched + 1 
        End If 
        ActiveCell.Offset(1, 0).Select 
    Loop 
    MsgBox "Total number of matches are : " & matched 
End Sub

Answer 1

Вот очень простой способ достичь того, что вы хотите сделать. Он просто предоставляет пользователю поле для ввода значения и копирует все строки, в которых это значение находится в столбце А, и помещает их на новый лист.

Sub CustomCopy()

Dim strsearch As String
Dim lastline As Long, toCopy As Long
Dim searchColumn As String
Dim i As Long, j As Long
Dim c As range

strsearch = CStr(InputBox("Enter the value to search for"))

lastline = range("A" & Rows.Count).End(xlUp).Row
j = 1

For i = 1 To lastline
    If range("A" & i).Value = strsearch Then
       Rows(i).Copy Destination:=Sheets(2).Rows(j)
       j = j + 1
    End If
Next

MsgBox j - 1 & " row(s) copied to Sheet2."

End Sub

Answer 2

Это должно сделать это, вам может потребоваться изменить xlWhole на xlPart в команде НАЙТИ.

Option Explicit

Sub CopyAndPaste()
Dim x As String, CpyRng As Range
Dim mFIND As Range, mFIRST As Range

    With Sheets("Sheet1")
        x = .Range("A55")
        On Error Resume Next
        Set mFIND = .Range("A1:A54").Find(x, LookIn:=xlValues, LookAt:=xlWhole)
        If Not mFIND Is Nothing Then
            Set CpyRng = mFIND
            Set mFIRST = mFIND

            Do
                Set CpyRng = Union(CpyRng, mFIND)
                Set mFIND = .Range("A1:A54").FindNext(mFIND)
            Loop Until mFIND.Address = mFIRST.Address

            CpyRng.EntireRow.Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
        End If
    End With
End Sub

Если вы переместите ячейку "x"вне столбца A или при использовании всплывающего окна вы можете просто выполнить поиск по всему столбцу A: A вместо обозначенного мной короткого диапазона.