Sub transferRemarks()
    Dim colD As Range, rng1 As Range, cell As Range
    Dim wks1 As Worksheet, wks2 As Worksheet
    Dim i As Long, vals As Variant
    Dim matchKey As String, matchPos As Double
    
    Set wks1 = Worksheets("Price")
    Set wks2 = Worksheets("Price2")
    Set colD = Intersect(wks2.UsedRange, wks2.Columns("D").Resize(wks2.Rows.Count - 1).Offset(1))
    Set rng1 = Intersect(wks1.UsedRange, wks1.Columns("A:D")).Resize(, 5)
    
'формирование в массиве "колонки" с ключами поиска для листа Price
    vals = rng1.Value
    For i = 1 To rng1.Rows.Count
        vals(i, 5) = vals(i, 1) & "_" & vals(i, 2) & "_" & vals(i, 3)
    Next i
    
'перебор непустых ячеек колонки D листа Price2
    On Error Resume Next
    For Each cell In colD.SpecialCells(xlCellTypeConstants, 23).Cells
        matchKey = cell.Offset(, -3) & "_" & cell.Offset(, -2) & "_" & cell.Offset(, -1)
        matchPos = WorksheetFunction.Match(matchKey, WorksheetFunction.Index(vals, 0, 5), 0)
        If Err Then
            'ОШИБКА: значение ключа поиска matchKey не найдено в Price
            Err.Clear
            Debug.Print "Для строки " & cell.Row & " листа Price2 не найдена строка на листе Price"
        Else
            'УСПЕХ: matchKey найдено - копируем
            cell.Copy wks1.Cells(matchPos, 4)
        End If
    Next cell
    On Error GoTo 0
End Sub

Sub transferRemarks_v2()
    Dim colD As Range, rng1 As Range, cell As Range
    Dim vals As Variant, matchKey As String, matchPos As Double
    Dim tbl1 As ListObject, tbl2 As ListObject
    
    Set tbl1 = Worksheets("Price2").ListObjects("Таблица1")
    Set tbl2 = Worksheets("Price").ListObjects("Таблица2")
    Set colD = tbl1.ListColumns("Примечание").DataBodyRange
    Set rng1 = tbl2.ListColumns("Артикул").Range 'колонка Артикул (с заголовком)
    
'формирование в массиве "колонки" с ключами поиска для листа Price
    vals = rng1.Value
    
'перебор непустых ячеек колонки D листа Price2
    On Error Resume Next
    For Each cell In colD.SpecialCells(xlCellTypeConstants, 23).Cells
        matchKey = cell.Offset(, -1) 'колонка Артикул
        matchPos = WorksheetFunction.Match(matchKey, vals, 0)
        If Err Then
            'ОШИБКА: значение ключа поиска matchKey не найдено в Price
            Err.Clear
            Debug.Print "Для строки " & cell.Row & " листа Price2 не найдена строка на листе Price"
        Else
            'УСПЕХ: matchKey найдено - копируем
            cell.Copy tbl2.Range.Cells(matchPos, 4)
        End If
    Next cell
    On Error GoTo 0
End Sub

Sub CopyForm()
  Dim Lr1%, Lr2%, Cl As Range, Dl As Range
  Lr1 = Sheets("Price2").Cells(Rows.Count, 3).End(xlUp).Row
  Lr2 = Sheets("Price").Cells(Rows.Count, 3).End(xlUp).Row
  Sheets("Price").Range("D2:D" & Lr2).Clear
  For Each Cl In Sheets("Price2").Range("C2:C" & Lr1)
    Cl.Offset(, 1).Copy
    Set Dl = Sheets("Price").Range("C2:C" & Lr2).Find(Cl.Value)
    If Not Dl Is Nothing Then Sheets("Price").Paste Dl.Offset(, 1)
  Next
  Application.CutCopyMode = False
End Sub

Worksheets("Price").ListObjects("Таблица2").ListColumns("Примечание").DataBodyRange.Clear

Sub Pry()
    With Application
        .ScreenUpdating = 0
        .DisplayAlerts = 0
        .Calculation = 3
        With Sheets("Price2")
            nr2_ = .Cells(.Rows.Count, 3).End(3).Row - 1
            ar21_ = .Cells(2, 3).Resize(nr2_).Value 'Артикул (столбец 3)
            ar22_ = .Cells(2, 4).Resize(nr2_).Value 'Примечание (столбец 4)
        End With
        With Sheets("Price")
            nr_ = .Cells(.Rows.Count, 3).End(3).Row - 1
            ar_ = .Cells(2, 3).Resize(nr_).Value 'Артикул (столбец 3)
            .Cells(2, 4).Resize(nr_).Clear 'Примечание (столбец 4)
            Set slov = CreateObject("Scripting.Dictionary")
            For i = 1 To nr_
                slov.Item(ar_(i, 1)) = i
            Next i
            For i = 1 To nr2_
                If ar22_(i, 1) <> "" Then
                    If slov.exists(ar21_(i, 1)) Then
                        Sheets("Price2").Cells(i + 1, 4).Copy .Cells(slov(ar21_(i, 1)) + 1, 4)
                    End If
                End If
            Next i
        End With
        .Calculation = 1
        .DisplayAlerts = 1
        .ScreenUpdating = 1
    End With
End Sub

Sub transferRemarks_v3()
    Dim cols1 As ListColumns, cols2 As ListColumns, headRow1 As Long, vals2 As Variant
    Dim cell As Range, matchKey As String, matchPos As Double
    
    Set cols1 = Worksheets("Price2").ListObjects("Таблица1").ListColumns
    headRow1 = cols1("Примечание").Range.Row
    
    Set cols2 = Worksheets("Price").ListObjects("Таблица2").ListColumns
    vals2 = cols2("Артикул").DataBodyRange.Value

'очистка всей колонки "Примечание" листа Price
    cols2("Примечание").DataBodyRange.Clear
    
'перебор непустых ячеек колонки D листа Price2
    On Error Resume Next
    For Each cell In cols1("Примечание").DataBodyRange.SpecialCells(xlCellTypeConstants, 23).Cells
        matchKey = cols1("Артикул").DataBodyRange(cell.Row - headRow1)
        matchPos = WorksheetFunction.Match(matchKey, vals2, 0)
        If Err Then
            'ОШИБКА: значение ключа поиска matchKey не найдено в Price
            Err.Clear
            Debug.Print "Для строки " & cell.Row & " листа Price2 не найдена строка на листе Price"
        Else
            'УСПЕХ: matchKey найдено - копируем
            cell.Copy cols2("Примечание").DataBodyRange(matchPos)
        End If
    Next cell
    On Error GoTo 0
End Sub

Dim colPrim2 As Range

Set colPrim2 = cols2("Примечание").DataBodyRange

Sub transferRemarks_v4()
    Dim headRow1 As Long, vals2 As Variant, matchKey As String, matchPos As Double
    Dim cell As Range, lc As ListColumn, dbr1 As New Collection, dbr2 As New Collection 'dbr = DataBodyRange
    
    With Worksheets("Price2").ListObjects("Таблица1")
        For Each lc In .ListColumns
            dbr1.Add lc.DataBodyRange, lc.Name
        Next lc
        headRow1 = .ListColumns("Примечание").Range.Row
    End With
       
    For Each lc In Worksheets("Price").ListObjects("Таблица2").ListColumns
        dbr2.Add lc.DataBodyRange, lc.Name
    Next lc
    vals2 = dbr2("Артикул") 'вот это особенно красиво выглядит

'очистка всей колонки "Примечание" листа Price
    dbr2("Примечание").Clear
    
'перебор непустых ячеек колонки D листа Price2
    On Error Resume Next
    For Each cell In dbr1("Примечание").SpecialCells(xlCellTypeConstants, 23).Cells
        matchKey = dbr1("Артикул")(cell.Row - headRow1)
        matchPos = WorksheetFunction.Match(matchKey, vals2, 0)
        If Err Then
            'ОШИБКА: значение ключа поиска matchKey не найдено в Price
            Err.Clear
            Debug.Print "Для строки " & cell.Row & " листа Price2 не найдена строка на листе Price"
        Else
            'УСПЕХ: matchKey найдено - копируем
            cell.Copy dbr2("Примечание")(matchPos)
        End If
    Next cell
    On Error GoTo 0
End Sub