VBA, для каждого совпадения приложения требуется объект

Question

Возникла проблема, связанная с совпадением приложений.Я получаю сообщение об ошибке Object required в строке K.Offset(0, 1).Copy FV.Offset(2, 0)

Код должен

1) проходить через диапазон CS,

2), где CS соответствует диапазону FV,

3) введите ячейки из CS Offset (0,1) в FV 2 столбца, Offset (2,0).

Вот мой полный код:

Sub n()

Dim FV As Variant
Dim CS As Variant
Dim K As Variant

FV = Sheets("NEW").Range("A28:A34").Value
CS = Sheets("CS").Range("A1:L1").Value

For Each K In CS
    If Not IsError(Application.Match(CS, FV, 0)) Then
        K.Offset(0, 1).Copy FV.Offset(2, 0)
        Else:
    End If
Next K

End Sub

Answer 1

Какой подвиг матча.Выпуск FirstMatch

Option Explicit

Sub XMatch()

  Const FirstMatch As Boolean = True
  Dim FV As Variant     ' Search Array (Vertical)
  Dim CS As Variant     ' Source Array (Horizontal)
  Dim K As Variant      ' Target Array (Vertical)
  Dim iFV As Integer    ' Search Array Rows Counter
  Dim iCS As Integer    ' Source Array Columns Counter

  ' Paste ranges into arrays.
  FV = Sheets("NEW").Range("A28:A34").Value       ' Search Array = Search Range
  CS = Sheets("CS").Range("A1:L2").Value          ' Source Array = Source Range

  ' The Target Array is the same size as the Search Array.
  ReDim K(1 To UBound(FV), 1 To 1)
  ' ReDim K(LBound(FV, 1) To UBound(FV, 1), LBound(FV, 2) To UBound(FV, 2))

  ' Loop through first and only COLUMN of first dimension of Search Array.
  For iFV = 1 To UBound(FV)
  ' For iFV = LBound(FV, 1) To UBound(FV, 1)

    ' Loop through first ROW of second dimension of Source Array.
    For iCS = 1 To UBound(CS, 2)
    ' For iCS = LBound(CS, 2) To UBound(CS, 2)

      If FV(iFV, 1) = CS(1, iCS) Then
        ' Match is found, read from second ROW of the second dimension of Source
        ' Array and write to first and only COLUMN of first dimension of Target
        ' Array.
        K(iFV, 1) = CS(2, iCS)
        ' Check True/False
        If FirstMatch Then
          ' When FirstMatch True, stop searching.
          Exit For
'         Else
          ' When FirstMatch False, try to find another match to use as result.
        End If
'       Else
        ' Match is not found.
      End If

    Next

  Next

  ' Paste Target Array into Target Range, which is two columns to the right of
  ' Search Range.
  Sheets("NEW").Range("A28:A34").Offset(0, 2) = K ' Target Range = Target Array

End Sub

Answer 2

Вы можете использовать чистую функцию VBA, например:

Sub CopyMatchingValues()
    Dim FV As Range
    Dim CS As Range
    Dim cellFV As Range
    Dim cellCS As Range

    Set FV = Sheets("NEW").Range("A28:A34")
    Set CS = Sheets("CS").Range("A1:L1")

    For Each cellCS In CS.Cells
        For Each cellFV In FV.Cells
            If cellFV.Value = cellCS.Value Then
                cellFV.Offset(2, 0).Value = cellCS.Offset(0, 1).Value
            End If
        Next
    Next
End Sub