返回与两个搜索条件相邻的值

Question

我需要从这样的表中查找与两个搜索条件相邻的值：

我写的代码是：

Dim mAin As Worksheet
Dim findc As Range
Dim findsc As Range
Dim code As Long
Dim scode As Integer
Dim i As Integer
Dim ttlrw As Long

i = 1
Set mAin = ActiveSheet
ttlrw = mAin.Columns(1).SpecialCells(xlCellTypeConstants).Count

Do
    code = mAin.Cells(i, 5).Value
    scode = mAin.Cells(i, 6).Value

    Set findc = mAin.Columns(1).Find(code)
    Set findsc = mAin.Columns(2).Find(scode)
    Do
        Set findc = mAin.Columns(1).FindNext(findc)
        Set findsc = mAin.Columns(2).FindNext(findsc)
    Loop Until findc.Row = findsc.Row

    mAin.Cells(i, 7).Value = findsc.Offset(0, 1).Value
    i = i + 1
Loop Until i = ttlrw + 1

找到的值应该与相似的表格相邻输出，但更混乱。

此外，宏在第 5 行之后进入无限循环。

我设法使用 INDEX、MATCH 和 &s 来解决这个问题，并将其转换为数组公式；但我也想进一步提高我对 VBA 的理解。

Answer 1

有很多方法可以做你想做的事。

Sub Example1_ForLoop()

    Dim lastRow As Long, x As Long
    Dim Criteria1 As Variant, Criteria2 As Variant

    Criteria1 = 2134
    Criteria2 = "003"

    lastRow = Range("A" & Rows.Count).End(xlUp).Row

    For x = 1 To lastRow
        If Cells(x, 1) = Criteria1 And Cells(x, 2) = Criteria2 Then

            Cells(x, 6) = Cells(x, 3)

        End If

    Next

End Sub


Sub Example2_ForEachLoop()

    Dim c As Range, SearchRange As Range
    Dim Criteria1 As Variant, Criteria2 As Variant

    Criteria1 = 2134
    Criteria2 = "003"

    Set SearchRange = Range("A1", Range("A" & Rows.Count).End(xlUp))

    For Each c In SearchRange
        If c = Criteria1 And c.Offset(0, 1) = Criteria2 Then

            c.Offset(0, 5) = c.Offset(0, 3)

        End If

    Next

End Sub

'Here is the proper way to use Find and FindNext.

Sub Example3_DoLoop_Find_FindNext()

    Dim c As Range, SearchRange As Range
    Dim firstAddress As String
    Dim Criteria1 As Variant, Criteria2 As Variant

    Criteria1 = 2134
    Criteria2 = "003"

    Set SearchRange = Range("A1", Range("A" & Rows.Count).End(xlUp))

    Set c = SearchRange.Find(Criteria1, LookIn:=xlValues)

    If Not c Is Nothing Then
        firstAddress = c.Address
        Do

            If c = Criteria1 And c.Offset(0, 1) = Criteria2 Then

                c.Offset(0, 5) = c.Offset(0, 3)

            End If

            Set c = SearchRange.FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If

End Sub

Answer 2

试试这个

Option Explicit

Sub mAin()
    Dim mAin As Worksheet
    Dim cell As Range

    With Worksheets("mAin") '<--| '<-- change "mAin" with your actual sheet name
        .Rows(1).Insert '<--| insert a dummy header row, it'll be eventually removed
        .Cells(1, 1).Resize(, 2).Value = Array("head1", "head2") '<--| write dummy headers
        With .Range("A1:B" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<--| reference its range in columns A:B from row 1 to column "A" last non empty cell row
            For Each cell In .Parent.Columns(5).SpecialCells(xlCellTypeConstants) '<-- loop through column "E" non empty cells
                .AutoFilter field:=1, Criteria1:=cell.Value 'operator:=xlAnd, '<--| filter referenced range on its 1st column with current cell value
                .AutoFilter field:=2, Criteria1:=cell.Offset(, 1).Value 'operator:=xlAnd, '<--| filter referenced range again on its 2nd column with current cell adjacent column value
                If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then '<--| if any cell other than header ones has been filtered...
                    cell.Offset(, 2) = .Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 3) '<--| copy current cell offseted 2 columns value to column "G"
                End If
                .Parent.AutoFilterMode = False '<--| show all rows back
            Next cell
        End With
        .Rows(1).Delete '<--| remove dummy header row
    End With
End Sub