Search & Copy function based on criteria that EXCLUDES invalid entries

idlewyld89

New Member
Joined
Jun 10, 2018
Messages
23
Alright so I feel like I'm 90% there... there's one particular problem in the routine.

Ultimately, I'm trying to increment through a dataset of 7000+ rows, search a defined column for a defined criteria, and then copy the entire row to a new sheet if that criteria is true within the searched cell.

The problem I'm having is that, in addition to the searched criteria, the code also copies over invalid entries (#N/A)... for the life of me I can't figure out how to avoid this.

I've tried the following two goes at this... both produce the same result as they are both similar routines. Also, as an FYI, the code in it's current form produces an invalid data type error when it hit's the aforementioned entries. To get around this, I wrapped the IF statement in an "On Error GoTo Next/GoTo 0." That of course forces it to ignore the error and therefore copy the undesired rows.

Code:
Private Sub CopySearchedData(ByVal Column As String, ByVal Criteria1 As String, ByVal Destination As String, ByVal Exclude As Boolean)

Dim i: i = 0
Dim j: j = Worksheets(Destination).Range("A" & Rows.Count).End(xlUp).Row


For i = 2 To LastRow


If (InStr(1, Worksheets(MainSheet).Range(Column + CStr(i)).Value, Criteria1) > 0 And Exclude = False) Then


    j = j + 1
    
    Worksheets(MainSheet).Rows(i).Copy
    Worksheets(Destination).Rows(j).PasteSpecial xlValues
    Worksheets(Destination).Rows(j).PasteSpecial xlFormats
    
ElseIf (Worksheets(MainSheet).Range(Column + CStr(i)).Value <> Criteria1 And Exclude = True) Then


    j = j + 1
    
    Worksheets(MainSheet).Rows(i).Copy
    Worksheets(Destination).Rows(j).PasteSpecial xlValues
    Worksheets(Desgination).Rows(j).PasteSpecial xlFormats
    
End If


Next


End Sub

Code:
Private Sub SearchAndExtract(ByVal Column1 As String, ByVal Criteria1 As String, ByVal Destination As String, Optional ByVal Column2 As String, Optional ByVal Criteria2 As Integer)

Dim i As Integer: i = 0
Dim j As Integer: j = Worksheets(Destination).Range("A" & Rows.Count).End(xlUp).Row


LastRow = Worksheets(MainSheet).Range("A" & Rows.Count).End(xlUp).Row


For i = 2 To LastRow


Worksheets(MainSheet).Select


If Cells(i, ReturnColumnLetter2(Column1, MainSheet)) = Criteria1 Then
        
        j = j + 1
        
        Worksheets(MainSheet).Rows(i).Copy
        Worksheets(Destination).Rows(j).PasteSpecial xlValues
        Worksheets(Destination).Rows(j).PasteSpecial xlFormats
    
    End If


Next


End Sub

Also, here's the called function to return the searched column letter, if it's helpful:

Code:
Private Function ReturnColumnLetter2(ByVal ColumnName As String, ByVal SheetName As String) As String' References:
' Dependents:


' ~~> Tests a string (ColumnName) against existing headers


Dim ColumnNumber As Integer


ColumnNumber = WorksheetFunction.Match(ColumnName, Sheets(SheetName).Rows(1), 0)


ReturnColumnLetter2 = Split(Cells(1, ColumnNumber).Address, "$")(1)


End Function
 

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
Instead of wrapping the If statement in an OnError Resume Next, wrap it in another If that tests is the cell value is a formula error.

Code:
If Not IsError(Worksheets(MainSheet).Range(Column + CStr(i)).Value) Then

Alternatively, instead of looping through each row and testing each cell in a column, you could autofilter the data set and copy all the filtered rows.
 
Upvote 0
Appreciate the suggestion, for the first round of sorting, this will work much better than my idea above. I'll still have to go back and fine-tune some selections with a line-by-line test, but on far fewer lines!!!

Question: Can AutoFilter parameters be expressed as variables? I've been trying to push the "Criteria1" parameter as a user response from a InputBox, but it seems to not like it. Probably just have a comma or period off, but at least I'll know if I'm on the right track or not!
 
Upvote 0

Forum statistics

Threads
1,223,911
Messages
6,175,323
Members
452,635
Latest member
laura12345

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top