vba - 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.

1. 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.
2. Whenever "1" is found, copy the entire row to "Sheet 1".
3. After completing search for "1", start for "2". When a match is found, copy entire row to "Sheet 2".
4. Similarly No. "3" and so on.
5. 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

    '~~> Remove any filters
    .AutoFilterMode = False

    '~~> I am assuming that the names are in Col A
    '~~> if not then change A below to whatever column letter
    lRow = .Range("A" & .Rows.Count).End(xlUp).Row

    With .Range("A3:A" & lRow)
        .AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*"
        Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
    End With

    '~~> Remove any filters
    .AutoFilterMode = False
End With

'~~> Destination File
Set wb2 = Application.Workbooks.Open("C:CSVimportSample.xlsx")
Set ws2 = wb2.Worksheets("Sheet" & i)

With ws2
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        lRow = .Cells.Find(What:="*", _
                      After:=.Range("A3"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
    Else
        lRow = 1
    End If

    copyFrom.Copy .Rows(lRow)
End With

wb2.Save
wb2.Close

Answer 1

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 worksheetworkbook 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