Using VBA to loop through different ranges and compare partial strings

Question

The problem I'm stuck with is as follows. I'm trying to cut "Price and Date" from an import page into a new table based on numerous criteria. I have a Specification sheet where I compare what those criteria have to be.

On the import page I have 3 criteria that have to be fulfilled first of all (these change based on the users input:

These are compared to a table which looks as follows: (This table doesn't change much. At most Origin and Key might be updated, or another row might be added)

For every line where Fruit, Type and Color match we have to look at another factor. Whether or not the fruit was bought from the "supermarket" or "farmer". On the import sheet we have the following table which changes every month.

When the fruit is bought at the Supermarket I want to use the correct key that corresponds with the row that fulfills the right criteria for "Fruit", "Type" and "Color". So in this example above I would like to use the key that corresponds with "Apple", "Fresh", "Red". Which in this example is just the first row. The corresponding key is "Supermarket ID 1" of which we have several rows of data in the import table. I would like to cut and paste the "Price" and "Date" from these rows into a new table.

For those fruits bought from the farmer it's a little different because 1) The comparable key is in a different column than the supermarket one and 2) The key is just a piece of the whole string of the import page (this is always the case). Here too I would like to cut the "Price" and "Date" into a different table.

Hopefully someone understands the problem. The code I've written so far is as follows:

Sub Fruits1()
Dim Criteria1 As Variant, Criteria2 As Variant, Criteria3 As Variant, Criteria4 As Variant, Criteria5 As Variant
Dim rng As Range, cell As Range
Dim wsImport As Worksheet: Set wsImport = Sheets("Import")
Dim wsSpec As Worksheet: Set wsSpec = Sheets("Specificaties")
Dim primarykey As String, comparingkey As String

Criteria1 = wsImport.Range("C3")
Criteria2 = wsImport.Range("C4")
Criteria3 = wsImport.Range("C5")

Set rng = wsSpec.Range("H3:H" & (wsSpec.Cells(Rows.Count, 8).End(xlUp).Row))


For Each cell In rng
    If cell.Value = Criteria1 And cell.Offset(0, 1).Value = Criteria2 And cell.Offset(0, 2).Value = Criteria3 Then
            If cell.Offset(0, 3) = "Supermarket" Then
                
                import_lastrow = wsImport.Range("E" & Rows.Count).End(xlUp).Row
                
                For i = import_lastrow To 2 Step -1
                    
                    primarykey = cell.Offset(0, 4).Value
                    comparingkey = wsImport.Cells(i, 13).Value
                
                    If InStr(primarykey, comparingkey) > 0 Then
                        MsgBox "cut Price and Data into new table"
                    End If
                    
                Next i
                    
            ElseIf cell.Offset(0, 4) = "Farmer" Then
                    
                    For i = import_lastrow To 2 Step -1
                    
                    primarykey = cell.Offset(0, 4).Value
                    comparingkey = wsImport.Cells(i, 8).Value
                
                    If InStr(primarykey, comparingkey) > 0 Then
                        MsgBox "cut Price and Data into new table"
                    End If
                    
                Next i
            End If
     End If
Next cell

End Sub

The problem I believe lies in that I'm trying to loop through different ranges and not doing it right.

Answer 1

Logic:

1. Use .Find and .Findnext to search for 1st criteria. It is much faster than looping through every cell and matching the first criteria
2. Once you have your "Supermarket/Farmer" use Autofilter on the relevant column to identify and copy the relevant rows.
3. After copying, delete the unnecessary columns (if you wish)

Code:

Ok is this what you are trying? (UNTESTED). I quickly wrote this. Let me know if you get any errors?

Option Explicit

Dim wsImport As Worksheet

Sub Sample()
    Dim wsSpec As Worksheet
    
    Set wsImport = ThisWorkbook.Sheets("Import")
    Set wsSpec = ThisWorkbook.Sheets("Specificaties")
    
    Dim CriteriaA As String, CriteriaB As String, CriteriaC As String
    Dim aCell As Range, bCell As Range
    Dim origin As String, KeyToFind As String
    
    With wsSpec
        CriteriaA = .Range("C3").Value2
        CriteriaB = .Range("C4").Value2
        CriteriaC = .Range("C5").Value2
        
        '~~> Using .Find to look for CriteriaA
        Set aCell = .Columns(8).Find(What:=CriteriaA, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
        '~~> Check if found or not
        If Not aCell Is Nothing Then
            Set bCell = aCell
            
            '~~> Secondary checks
            If aCell.Offset(, 1).Value2 = CriteriaB And _
               aCell.Offset(, 2).Value2 = CriteriaC Then '<~~ If match found
               '~~> Get the origin and the key
               origin = aCell.Offset(, 3).Value2
               KeyToFind = aCell.Offset(, 4).Value2
            Else '<~~ If match not found then search for next match
               Do
                   Set aCell = .Columns(8).FindNext(After:=aCell)
        
                   If Not aCell Is Nothing Then
                        If aCell.Address = bCell.Address Then Exit Do
                        
                        If aCell.Offset(, 1).Value2 = CriteriaB And _
                           aCell.Offset(, 2).Value2 = CriteriaC Then
                           origin = aCell.Offset(, 3).Value2
                           KeyToFind = aCell.Offset(, 4).Value2
                           Exit Do
                        End If
                   Else
                       Exit Do
                   End If
               Loop
            End If
            
            '~~> Check the origin
            If origin = "Supermarket" Then
                CopyRows "F", KeyToFind, False
            ElseIf origin = "Farmer" Then
                CopyRows "H", KeyToFind, True
            Else
                MsgBox "Please check origin. Supermarket/Farmer not found. Exiting..."
            End If
        Else
            MsgBox "Criteria A match was not found. Exiting..."
        End If
    End With
End Sub

'~~> Autofilter and copy filtered data
Private Sub CopyRows(Col As String, SearchString As String, PartialString As Boolean)
    Dim copyFrom As Range
    Dim lRow As Long
    
    With wsImport
        '~~> Remove any filters
        .AutoFilterMode = False
        
        lRow = .Range(Col & .Rows.Count).End(xlUp).Row

        With .Range(Col & "1:" & Col & lRow)
            If PartialString = False Then
                .AutoFilter Field:=1, Criteria1:=SearchString
            Else
                .AutoFilter Field:=1, Criteria1:="=*" & SearchString & "*"
            End If
            
            Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
        End With

        '~~> Remove any filters
        .AutoFilterMode = False
    End With
    
    '~~> Some sheet where you want to paste the output
    Dim SomeSheet As Worksheet
    Set SomeSheet = ThisWorkbook.Sheets("Output")
    
    If Not copyFrom Is Nothing Then
        '~~> Copy and paste to some sheet
        copyFrom.Copy SomeSheet.Rows(1)
        
        'After copying, delete the unwanted columns (OPTIONAL)
    End If
End Sub