Copy a row in excel if it matches a specific criteria into a new worksheet

Question

I'm a novice to VBA and having issues in copying rows in one sheet to another based on certain criteria. I have tried searching for an answer in this forum, tried modifying the code to suit my requirement but been unsuccessful. Please help me. - I need to search for no.s in column A of a worksheet. The search should start with No. 1, then 2, then 3 and so on. - Whenever "1" is found, copy the entire row to "Sheet 1". - After completing search for "1", start for "2". When a match is found, copy entire row to "Sheet 2". - Similarly No. "3" and so on. - Repeat this search for other no.s till end of column A. I have tried the following code: Note: i will vary from 1 to a pre-determined value. ``` Dim wb1 As Workbook, wb2 As Workbook Dim ws1 As Worksheet, ws2 As Worksheet Dim copyFrom As Range Dim lRow As Long '<~~ Not Integer. Might give you error in higher versions of excel Dim strSearch As Integer Set wb1 = ActiveWorkbook Set ws1 = wb1.Worksheets("Burn Down") strSearch = "1" With ws1 '~…

Accepted Answer

Here's an alternative way of doing it. I don't like using filters, I prefer to loop through each record. Maybe it's a litte slower but I think it's more robust.

- The below should work but I didn't understand if you wanted to paste the row into a new worksheet in the current workbook or a new workbook.

- The below code pastes into the current workbook but that can easily be changed.

- I'm also assuming you will want to keep pasting new rows into the worksheet so therefore you don't want to overwrite any previous data you have written.

You would also want to put in some extra error checking like ensure the worksheet\workbook exits, ensure the value in Column A is numeric etc. The below has none.

```
Sub copyBurnDownItem()

Dim objWorksheet As Worksheet
Dim rngBurnDown As Range
Dim rngCell As Range
Dim strPasteToSheet As String

'Used for the new worksheet we are pasting into
Dim objNewSheet As Worksheet
Dim rngNextAvailbleRow As Range

'Define the worksheet with our data
Set objWorksheet = ThisWorkbook.Worksheets("Burn Down")

'Dynamically define the range to the last cell.
'This doesn't include and error handling e.g. null cells
'If we are not starting in A1, then change as appropriate
Set rngBurnDown = objWorksheet.Range("A1:A" & objWorksheet.Cells(Rows.Count,     "A").End(xlUp).Row)

'Now loop through all the cells in the range
For Each rngCell In rngBurnDown.Cells

objWorksheet.Select

If rngCell.Value <> "" Then
    'select the entire row
    rngCell.EntireRow.Select

'copy the selection
    Selection.Copy

'Now identify and select the new sheet to paste into
    Set objNewSheet = ThisWorkbook.Worksheets("Sheet" & rngCell.Value)
    objNewSheet.Select

'Looking at your initial question, I believe you are trying to find the next     available row
    Set rngNextAvailbleRow = objNewSheet.Range("A1:A" &     objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)

Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
    ActiveSheet.Paste
End If

Next rngCell

objWorksheet.Select
objWorksheet.Cells(1, 1).Select

'Can do some basic error handing here

'kill all objects
If IsObject(objWorksheet) Then Set objWorksheet = Nothing
If IsObject(rngBurnDown) Then Set rngBurnDown = Nothing
If IsObject(rngCell) Then Set rngCell = Nothing
If IsObject(objNewSheet) Then Set objNewSheet = Nothing
If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing

End Sub
```

Copy a row in excel if it matches a specific criteria into a new worksheet

Solution

Problem