Sub Перенести()

    Dim shSrc As Worksheet, shRes As Worksheet
    Dim lrSrc As Long, r As Long, i As Long
    
    Application.ScreenUpdating = False
    
    Set shSrc = Worksheets("2016_платные")
    Set shRes = Worksheets("2016_омс")
    
    lrSrc = shSrc.Cells(shSrc.Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To lrSrc
        On Error Resume Next
        r = 0
        r = WorksheetFunction.Match(shSrc.Cells(i, "A").Value, shRes.Columns("C"), 0)
        On Error GoTo 0
        If r = 0 Then
            GoTo metka
        End If
        
        If shRes.Cells(r, "J").Value = "" Then
            shRes.Cells(r, "J").Value = shSrc.Cells(i, "B").Value
        Else
            shRes.Cells(r, "J").Value = shRes.Cells(r, "J").Value & ", " & shSrc.Cells(i, "B").Value
        End If
    
        If shRes.Cells(r, "K").Value = "" Then
            shRes.Cells(r, "K").Value = shSrc.Cells(i, "C").Value
        Else
            shRes.Cells(r, "K").Value = shRes.Cells(r, "K").Value & ", " & shSrc.Cells(i, "C").Value
        End If
    
        If shRes.Cells(r, "L").Value = "" Then
            shRes.Cells(r, "L").Value = shSrc.Cells(i, "D").Value
        Else
            shRes.Cells(r, "L").Value = shRes.Cells(r, "L").Value & ", " & shSrc.Cells(i, "D").Value
        End If
    
        If shRes.Cells(r, "M").Value = "" Then
            shRes.Cells(r, "M").Value = shSrc.Cells(i, "E").Value
        Else
            shRes.Cells(r, "M").Value = shRes.Cells(r, "M").Value & ", " & shSrc.Cells(i, "E").Value
        End If
        
metka:
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "Готово!", vbInformation

End Sub