Sub Перенести_данные()

    Dim shSrc As Worksheet, shRes As Worksheet
    Dim arrSrcB(), arrResA()
    Dim i As Long, r As Long
    
    Application.ScreenUpdating = False
    Set shRes = ActiveSheet
    'здесь укажите путь и имя файла, из которого надо перенести данные
    Set shSrc = Workbooks.Open(Filename:="C:\Users\User\Desktop\03.04.2018_19_3.xls", ReadOnly:=True).Worksheets(1)
    Получить_столбец_B_из_источника shSrc, arrSrcB()
    Получить_столбец_A_из_результата shRes, arrResA()
    
    On Error Resume Next
    For i = 1 To UBound(arrResA)
        If arrResA(i, 1) <> "" And arrResA(i, 1) <> "Оператор" Then
            r = 0
            r = WorksheetFunction.Match(arrResA(i, 1), arrSrcB(), 0)
            If r <> 0 Then
                shRes.Cells(i, "B").Value = shSrc.Cells(r, "C").Value
                shRes.Cells(i, "C").Value = shSrc.Cells(r, "F").Value
                shRes.Cells(i, "D").Value = shSrc.Cells(r, "I").Value
                shRes.Cells(i, "E").Value = shSrc.Cells(r, "K").Value
                shRes.Cells(i, "F").Value = "?"
                shRes.Cells(i, "G").Value = "?"
            End If
        End If
    Next i
    On Error GoTo 0
    
    shSrc.Parent.Close SaveChanges:=False
    Application.ScreenUpdating = True
    MsgBox "Готово!", vbInformation
    
End Sub

Private Sub Получить_столбец_B_из_источника(shSrc As Worksheet, arr())
    
    Dim var, lr As Long, i As Long
    
    lr = shSrc.Cells(shSrc.Rows.Count, "B").End(xlUp).Row
    arr() = shSrc.Range("B1").Resize(lr).Value
    For i = 2 To UBound(arr)
        If i = 22 Then Stop
        arr(i, 1) = WorksheetFunction.Trim(arr(i, 1))
        arr(i, 1) = Replace(arr(i, 1), ". ", ".")
        If Right(arr(i, 1), 1) <> "." Then
            arr(i, 1) = arr(i, 1) & "."
        End If
    Next i
    
End Sub

Private Sub Получить_столбец_A_из_результата(shRes As Worksheet, arr())

    Dim var, lr As Long, i As Long
    
    lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row
    arr() = shRes.Range("A1").Resize(lr).Value
    For i = 1 To UBound(arr)
        arr(i, 1) = WorksheetFunction.Trim(arr(i, 1))
        var = Split(arr(i, 1), " ")
        If UBound(var) = 2 Then
            var(1) = Left(var(1), 1) & "."
            var(2) = Left(var(2), 1) & "."
            arr(i, 1) = var(0) & " " & var(1) & var(2)
        End If
    Next i
    
End Sub