使用 VBA 循环遍历不同的范围并比较部分字符串

Question

我遇到的问题如下。 我正在尝试根据众多标准将“价格和日期”从导入页面剪切到新表中。 我有一个规格表，我比较这些标准必须是什么。

在导入页面上，我首先必须满足 3 个标准（这些更改基于用户输入：

这些与看起来如下的表进行比较：（此表没有太大变化。最多可能会更新 Origin 和 Key，或者可能会添加另一行）

对于水果、类型和颜色匹配的每一行，我们都必须考虑另一个因素。 水果是从“超市”还是“农夫”购买的。 在导入表上，我们有下表，每个月都会更改。

在超市购买水果时，我想使用与满足“水果”、“类型”和“颜色”正确标准的行相对应的正确键。 所以在上面的这个例子中，我想使用与“Apple”、“Fresh”、“Red”对应的键。 在此示例中，这只是第一行。 对应的键是“Supermarket ID 1”，我们在导入表中有几行数据。 我想将这些行中的“价格”和“日期”剪切并粘贴到一个新表中。

对于那些从农民那里购买的水果，它有点不同，因为 1) 可比较的键与超市一列在不同的列中，并且 2) 键只是导入页面的整个字符串的一部分（总是如此） . 在这里，我也想将“价格”和“日期”切成不同的表格。

希望有人理解这个问题。 到目前为止，我编写的代码如下：

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

我相信的问题在于我试图遍历不同的范围并且做得不对。

Answer 1

逻辑：

1. 使用.Find 和 .Findnext搜索第一个条件。 它比遍历每个单元格并匹配第一个条件要快得多
2. 一旦你有你的“超市/农民”，在相关列上使用自动过滤器来识别和复制相关行。
3. 复制后，删除不必要的列（如果您愿意）

代码：

好的，这是您正在尝试的吗？ （未经测试）。 我很快就写了这个。 如果您有任何错误，请告诉我？

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