Copying rows from one Excel sheet to another based on cell value - excel

Question

I'm looking for a simple excel macro that can copy a row from one sheet to another within excel based upon having a specific number/value in the cell. I have two sheets. One called "master" and a sheet called "top10".
Here is an example of the data.
Here's the macro I'm trying to use:
Sub MyMacro()
Dim i As Long, iMatches As Long
Dim aTokens() As String: aTokens = Split("10", ",")
For Each cell In Sheets("master").Range("A:A")
If (Len(cell.Value) = 0) Then Exit For
For i = 0 To UBound(aTokens)
If InStr(1, cell.Value, aTokens(i), vbTextCompare) Then
iMatches = (iMatches + 1)
Sheets("master").Rows(cell.Row).Copy Sheets("top10").Rows(iMatches)
End If
Next
Next
End Sub
I'm sure I'm doing something extremely silly that's causing this not to work. I can run the macro itself without any error, but nothing gets copied to the sheet I'm looking to compile.

Answer 1

If (Len(cell.Value) = 0) Then Exit For is nonsense. Change it like below:
Sub MyMacro()
Dim i As Long, iMatches As Long
Dim aTokens() As String: aTokens = Split("10", ",")
For Each cell In Sheets("master").Range("A:A")
If Len(cell.Value) <> 0 Then
For i = 0 To UBound(aTokens)
If InStr(1, cell.Value, aTokens(i), vbTextCompare) Then
iMatches = (iMatches + 1)
Sheets("master").Rows(cell.Row).Copy Sheets("top10").Rows(iMatches)
End If
Next
End If
Next
End Sub

Answer 2

I believe the reason your code stops after the first row of data is because the cell your are testing in the next row is empty (in your example spreadsheet) and therefore you exit the loop (because Len(cell.Value) = 0). I would suggest a different approach: an advanced filter does exactly what you need, and is faster. In your example spreadsheet, you will need to insert an empty row 2 and put the formula "=10" in cell A2. Then the code below will do what you need (assuming thatmaster is the ActiveSheet):
Sub CopyData()
Dim rngData As Range, lastRow As Long, rngCriteria As Range
With ActiveSheet
' This finds the last used row of column A
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
' Defines the criteria range - you can amend it with more criteria,
' it will still work
' 22 is the number of the last column in your example spreadsheet
Set rngCriteria = .Range(.Cells(1, 1), .Cells(2, 22))
' row 2 has the filter criteria, but we will delete it after copying
Set rngData = .Range(.Cells(1, 1), .Cells(lastRow, 22))
' Make sure the destination sheet is clear
' You can replace sheet2 with Sheets("top10"),
' but if you change the sheet name your code will not work any more.
' Using the vba sheet name is usually more stable
Sheet2.UsedRange.ClearContents
' Here we select the rows we need based on the filter
' and copy it to the other sheet
Call rngData.AdvancedFilter(xlFilterCopy, rngCriteria, Sheet2.Cells(1, 1))
' Again, replacing Sheet2 with Sheets("top10")..
' Row 2 holds the filter criteria so must be deleted
Sheet2.Rows(2).Delete
End With
End Sub
For a reference to advanced filters, check out this link:
http://chandoo.org/wp/2012/11/27/extract-subset-of-data/

Answer 3

As #Ioannis mentioned, your problem is the empty cell in master A3 combined with your If (Len(cell.Value) = 0) Then Exit For
Instead of using an that if to detect the end of your range I used the following code:
LastRow= Sheets("master").Cells(Cells.Rows.Count, "A").End(xlUp).Row
Set MyRange = Sheets("master").Range("A1:A" & LastRow)
The resulting code is this:
Sub MyMacro()
Dim i As Long, iMatches As Long
Dim aTokens() As String: aTokens = Split("10", ",")
Dim LastRow
Dim MyRange
LastRow = Sheets("master").Cells(Cells.Rows.Count, "A").End(xlUp).Row
Set MyRange = Sheets("master").Range("A1:A" & LastRow)
For Each cell In MyRange
For i = 0 To UBound(aTokens)
If InStr(1, cell.Value, aTokens(i), vbTextCompare) Then
iMatches = (iMatches + 1)
Sheets("master").Rows(cell.Row).Copy Sheets("top10").Rows(iMatches)
End If
Next
Next
End Sub
I tested this with your workbook and it works perfectly. :-)