Использование каждого для сравнения нескольких столбцов в каждой рабочей книге и копирования третьего столбца в одну из рабочих книг.

Question

Я сопоставляю два столбца в новой рабочей книге с двумя столбцами в Рабочей книге 2, а затем извлекаю столбец B из Рабочей книги2 и копирую его в столбец B новой рабочей книги. Некоторые клетки будут пустыми. Выполнение следующего кода не приводит к копированию ничего. Я не уверен, что использую правильный подход для получения информации.

    Sub InsertDeviceName_NewBook()

      Dim w1 As Worksheet, w2 As Worksheet, wsnew As Worksheet
      Dim wbnew As Workbook
      Dim c As Range, FR As Variant
      Dim d As Range
      Dim e As Range, rng1 As Range, rng2 As Range
      Dim lr1 As Long, lr2 As Long


      Application.ScreenUpdating = False


      Set w2 = Workbooks("Book2.xlsx").ActiveSheet
      Set w1 = Workbooks("Book1.xlsx").ActiveSheet



     w1.Range("B:D").Copy
     Set wbnew = Workbooks.Add 'creates new workbook
     Columns("A:A").Select
     ActiveSheet.Paste
     Application.CutCopyMode = False
     ActiveSheet.Name = w1.Name
     Set wsnew = wbnew.ActiveSheet 'sets the active sheet in the new workbook
     lr1 = wsnew.Cells(Rows.count, 1).End(xlUp).Row
     lr2 = w2.Cells(Rows.count, 1).End(xlUp).Row


     wsnew.Sort.SortFields.Add2 Key:=Range("B1"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With wsnew.Sort
        .SetRange Range("A1:C" & lr1)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
   End With

Columns("B:B").Insert Shift:=xlToRight, _
      CopyOrigin:=xlFormatFromLeftOrAbove

      Range("B1").Select
      ActiveCell.FormulaR1C1 = "Device Name"

      Dim lr3 As Long

      lr3 = wsnew.Cells(Rows.count, 1).End(xlUp).Row

      Set rng1 = wsnew.Range("C2:D" & lr3)
      Set rng2 = w2.Range("C2:D" & lr2)

'create a loop to find matches between columns C and D in the new workbook
'and match with columns C and D in workbook 2, upon a match retrieve the information
'in column B in workbook2 and add it to Columns B in the new workbook

For Each d In rng1
    FR = Application.Match(d, rng2)
    If IsNumeric(FR) Then
    d.Offset(, -1).Value = w2.Range("B" & FR).Value
    End If

Next d

Application.ScreenUpdating = True

End Sub

Answer 1

Не сработает ли здесь формула соответствия индекса? Это будет захватывать значения, которые соответствуют друг другу, тогда вы можете просто скопировать результаты и вставить в качестве значения.

В этом примере в качестве возврата используется одна ячейка, но вы можете изменить ее на формулу строки и вернуть правильные результаты для каждого ряда.

Пример совпадения индекса с несколькими критериями