Возвращаясь значение рядом с двумя критериями поиска

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.

мне удалось решить это с помощью индекса, MATCH, & с и превращение его в формулу массива; но я также хотел бы еще больше улучшить понимание 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