Option Explicit

Sub ImportData()
Dim s$, x, cc As Range
s = Application.GetOpenFilename("Текстовые файлы (*.txt),*.txt,Все файлы (*.*),*.*")
If s = "False" Then Exit Sub
With CreateObject("Scripting.dictionary")
.CompareMode = 1 'TextCompare
Open s For Input As #1
Do Until EOF(1)
Line Input #1, s
If InStr(s, "/") Then
x = Split(s, "/")(0)
If x <> "" Then .Item(x) = Split(s, "/")(1)
End If
Loop
Reset

For Each cc In Selection.Cells
If .exists(cc.Value) Then cc.Offset(, 14) = .Item(cc.Value)
Next
End With
End Sub

Option Explicit

Sub ImportData()
Dim s$, x, cc As Range
With CreateObject("Scripting.dictionary")
.CompareMode = 1 'TextCompare
Open "C:\temp\loaded.txt" For Input As #1
Do Until EOF(1)
Line Input #1, s
If InStr(s, "/") Then
x = Split(s, "/")(0)
If x <> "" Then .Item(x) = Replace(Split(s, "/")(1), " ", "")
End If
Loop
Reset

For Each cc In Selection.Cells
If .exists(cc.Value) Then cc.Offset(, 14) = .Item(cc.Value)
Next
End With
End Sub

Option Explicit

Sub ImportData()
Dim s$, x, cc As Range, diap$
Dim n&, m&, calc_status

diap = InputBox("Запрос строк", "Введите данные вида n/m")
If diap = "" Then Exit Sub
n = Split(diap, "/")(0)
m = Split(diap, "/")(1)

With Application
.EnableEvents = False
.ScreenUpdating = False
calc_status = .Calculation
.Calculation = xlCalculationManual
End With

With CreateObject("Scripting.dictionary")
.CompareMode = 1 'TextCompare
Open "C:\temp\Ed_Vard\2\loaded.txt" For Input As #1
Do Until EOF(1)
Line Input #1, s
If InStr(s, "/") Then
x = Split(s, "/")(0)
If x <> "" Then .Item(x) = Replace(Split(s, "/")(1), " ", "")
End If
Loop
Reset

For Each cc In Range(Cells(n, 1), Cells(m, 1))
If .exists(cc.Value) Then cc.Offset(, 14) = .Item(cc.Value)
Next
End With

With Application
.Calculation = calc_status
.EnableEvents = True
.ScreenUpdating = True
End With

End Sub

If .exists(cc.Value) Then cc.Offset(, 14) = .Item(cc.Value): cc.Offset(, 15) = Now

Sub OpenRtfAndPasteToSheets()
Dim wd As Object
Dim ns As Worksheet

On Error Resume Next
'запустим Ворд
Set wd = GetObject("", "Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set wd = CreateObject("Word.Application")
If Err.Number <> 0 Then Exit Sub
End If

On Error GoTo BAD

Do
'получим имя очередного файла
f = Application.GetOpenFilename("Файлы RTF, *.rtf,Все файлы, *.*")
If TypeName(f) = "Boolean" Then Exit Do 'если Отмена - выход
'откроем выбранный очередной файл
Set wdd = wd.Documents.Open(f)
' wd.Visible = True
'скопируем содержимое документа
t = wdd.Content.Copy
'создадим лист для этого документа
Set ns = ActiveWorkbook.Worksheets.Add
'вставим скопированное в новый лист
ns.Paste Destination:=ns.Cells(1, 1)
'немного выравним вид
ns.Cells.WrapText = False
ns.Columns.AutoFit
ns.Rows.AutoFit
wdd.Close
Loop
wd.Quit
Set wd = Nothing
Exit Sub
BAD:
MsgBox Err.Description
On Error Resume Next
wd.Quit
Set wd = Nothing
End
End Sub

Sub OpenRtfAndPasteToSheets()
         Dim wd As Object
         Dim ns As Worksheet

         On Error Resume Next
         'запустим Ворд
         Set wd = GetObject("", "Word.Application")
         If Err.Number <> 0 Then
             Err.Clear
             Set wd = CreateObject("Word.Application")
             If Err.Number <> 0 Then Exit Sub
         End If

         On Error GoTo BAD

         'получим имя очередного файла
         f = Application.GetOpenFilename("Файлы RTF, *.rtf,Все файлы, *.*")
         If TypeName(f) = "Boolean" Then End    'если Отмена - выход
         'откроем выбранный файл
         Set wdd = wd.Documents.Open(f)
         '    wd.Visible = True
         'скопируем содержимое документа
         t = wdd.Content.Copy
         Dim MyData As DataObject
         Set MyData = New DataObject
         MyData.GetFromClipboard
         test = MyData.GetText(1)
         test = Mid(test, InStr(test, "Входящий номер: ") + 16, 14)
         MsgBox test
         wd.Quit
         Set wd = Nothing
         Exit Sub
BAD:
         MsgBox Err.Description
         On Error Resume Next
         wd.Quit
         Set wd = Nothing
         End
End Sub