Find, select, and copy row

问题

How do I find a cell containing a certain string in a certain column, then select the entire row and copy that row using Excel vba?

I am relatively new to using Excel VBA and have spent days trying to code this myself. I am working on a worksheet in which different datasets are copied into. Every data set will contain the string "page" in some cell of column A, however the row varies from dataset to dataset. I now need some vba code to first identify the cell of column A that contains the string "Page", then select that entire row and copy it below the last row of the table (whose number of rows also varies). I already managed to write some code that copies an entire row to the bottom of the table so I could also reuse that code, the main issue is with identifying the right row that contains the string. Can someone help me with this?

Thanks in advance!

回答1:

You could try:

Sub test()

    Dim strSearch As String
    Dim ColumnNo As Long, LastRow As Long
    Dim rngFound  As Range
    Dim wsDestination As Worksheet, wsSource As Worksheet
    
    'set worksheets
    With ThisWorkbook
        Set wsSource = .Worksheets("Sheet1")
        Set wsDestination = .Worksheets("Overview")
    End With
    
    'Set the value you want to search
    strSearch = "*Page*"
    
    'Set the column you want to seach
    ColumnNo = 1
    
    'Create a with statement to point Sheet1.
    With wsSource
        
        'Search for strSearch in column number ColumnNo
        Set rngFound = .Columns(ColumnNo).Find(strSearch, LookIn:=xlValues, lookat:=xlWhole)
        
        If Not rngFound Is Nothing Then
            LastRow = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row + 1
            'Copy row.
            .Rows(rngFound.Row).EntireRow.Copy
            'Paste row
            wsDestination.Rows(LastRow).PasteSpecial Paste:=xlPasteValues
            'Delete row
            .Rows(rngFound.Row).EntireRow.Delete Shift:=xlUp
        Else
            'Msg box
            MsgBox "Value not found."
        End If
        
    End With
      
End Sub

回答2:

Here is a code to copy entire rows from sheet called Sheet1 to another sheet called Sheet2 with criteria "Page"

Private Sub test()
Dim i As Integer, lastrow As Integer, newrow As Integer
lastrow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lastrow
If Worksheets("Sheet1").Range("A" & i) Like "*" & "Page" & "*" Then
Worksheets("Sheet1").Range("A" & i).EntireRow.Copy
Worksheets("Sheet2").Activate
newrow = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("Sheet2").Cells(newrow, 1).Select
ActiveSheet.Paste
End If
Next i
End Sub

来源：https://stackoverflow.com/questions/63629194/find-select-and-copy-row