Sub Serge_007()
     Application.ScreenUpdating = False
     Application.DisplayAlerts = False
     Rows("1:2").UnMerge
     Range("O1:R1") = Range("O2:R2")
     Rows("2:2").Delete Shift:=xlUp
     For Each sh In Worksheets
         If sh.Name = "Справочник" Then sh.Delete
     Next
     Set wb = GetObject("d:\Excel_Макрос\0.xls")
     wb.Sheets("Справочник").Copy After:=Sheets(Sheets.Count)
     wb.Close False
     Sheets("Рабочий").Activate
     arr = Sheets("Справочник").Range("A1").CurrentRegion.Value
     With CreateObject("Scripting.Dictionary")
         For i = 1 To UBound(arr)
             .Item(arr(i, 1)) = arr(i, 2)
         Next
         arr = Range(Cells(1, "S"), Cells(Rows.Count, "X").End(xlUp)).Value
         For i = 1 To UBound(arr)
             For j = 1 To UBound(arr, 2)
                 If .exists(arr(i, j)) Then
                     arr(i, j) = .Item(arr(i, j))
                 Else
                     Cells(i, 18 + j).Interior.Color = vbRed
                 End If
             Next: Next
     End With
     Range(Cells(1, "S"), Cells(Rows.Count, "X").End(xlUp)) = arr
     Application.DisplayAlerts = True
     Application.ScreenUpdating = True
End Sub

  Cells(i, 18 + j).Interior.Color = vbRed
                     Strc = Strc & "; " & Cells(i, 18 + j).Address
                 End If
             Next: Next
     End With
     Range(Cells(1, "S"), Cells(Rows.Count, "X").End(xlUp)) = arr
     Application.DisplayAlerts = True
     Application.ScreenUpdating = True
     MsgBox Mid$(Strc, 2)

Sub tt()
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
fp_ = "D:\Мои_\Стереть\" ' путь
fn_ = "Для_справочника.xls" ' название файла
sn_ = "Справочник" ' название листа
asn_ = ThisWorkbook.ActiveSheet.Name
On Error Resume Next
     Workbooks.Open Filename:=fp_ & fn_
     ThisWorkbook.Activate
     q = Workbooks(fn_).Sheets(sn_).Range("A1")
     If Err.Number Then
         MsgBox "Нет или книги " & fp_ & fn_ & ", или листа " & sn_
         Exit Sub
     End If
     ThisWorkbook.Sheets("Справочник").Delete
     Workbooks(fn_).Sheets(sn_).Copy After:=ThisWorkbook.Sheets(Sheets.Count)
     Worksheets(asn_).Activate
     Windows("Для_справочника.xls").Close
     Err = ""
On Error GoTo 0
With ThisWorkbook.Sheets(asn_)
     .Rows("1:2").UnMerge
     .Range("O2:R2").Cut Destination:=.Range("O1:R1")
     .Rows("2:2").Delete Shift:=xlUp
     c_ = .Cells(1, Columns.Count).End(xlToLeft).Column
     If c_ > 18 Then
     r_ = Sheets(sn_).Range("A" & Rows.Count).End(xlUp).Row
         For i = 19 To c_
             On Error Resume Next
             .Cells(1, i) = WorksheetFunction.VLookup(.Cells(1, i), Sheets(sn_).Range("A1:B" & r_), 2, 0)
             If Err.Number Then
                 .Cells(1, i).Interior.Color = 255
                 e_ = e_ + 1
                 Err = ""
             End If
             On Error GoTo 0
         Next i
         If e_ Then MsgBox "Фигня какая-то в шапке. Посмотри в красных ячейках."
     End If
End With
Application.ScreenUpdating = 1
Application.DisplayAlerts = 1
End Sub

Rows("2:2").Delete Shift:=xlUp
     On Error GoTo error_S
     Set wb = GetObject("d:\Excel_Макрос\0.xls")
     Set sh = wb.Sheets("Справочник"): Set sh = Nothing
     For Each sh In ThisWorkbook.Worksheets
         If sh.Name = "Справочник" Then sh.Delete
     Next
     wb.Sheets("Справочник").Copy After:=Sheets(Sheets.Count)
     wb.Close False: Set wb = Nothing
error_S:
     On Error GoTo 0
     Sheets("Рабочий").Activate

Range("O1:R1") = Range("O2:R2")

Range("O2:R2").AutoFill Destination:=Range("O1:R2")

CutCopyMode =

Sub tt()
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
fp_ = "D:\Мои_\Стереть\" ' путь
fn_ = "Для_справочника.xls" ' название файла
sn_ = "Справочник" ' название листа
asn_ = ThisWorkbook.ActiveSheet.Name
On Error Resume Next
     Workbooks.Open Filename:=fp_ & fn_
     ThisWorkbook.Activate
     q = Workbooks(fn_).Sheets(sn_).Range("A1")
     If Err.Number Then
         MsgBox "Нет или книги " & fp_ & fn_ & ", или листа " & sn_
         Exit Sub
     End If
     ThisWorkbook.Sheets("Справочник").Delete
     Workbooks(fn_).Sheets(sn_).Copy After:=ThisWorkbook.Sheets(Sheets.Count)
     Worksheets(asn_).Activate
     Windows("Для_справочника.xls").Close
     Err = ""
On Error GoTo 0
With ThisWorkbook.Sheets(asn_)
     .Rows("1:2").UnMerge
     .Range("O2:R2").Cut Destination:=.Range("O1:R1")
     .Rows("2:2").Delete Shift:=xlUp
     c_ = .Cells(1, Columns.Count).End(xlToLeft).Column
     If c_ > 18 Then
     r_ = Sheets(sn_).Range("A" & Rows.Count).End(xlUp).Row
         For i = 19 To c_
             On Error Resume Next
             .Cells(1, i) = WorksheetFunction.VLookup(.Cells(1, i), Sheets(sn_).Range("A1:B" & r_), 2, 0)
             If Err.Number Then
                 .Cells(1, i).Interior.Color = 255
                 e_ = e_ & .Cells(1, i).Address(0, 0) & ", "
                 Err = ""
             End If
             On Error GoTo 0
         Next i
         If e_ <> "" Then MsgBox "Фигня какая-то в шапке. Посмотри в ячейках " & e_ & "они красные."
     End If
End With
Application.ScreenUpdating = 1
Application.DisplayAlerts = 1
End Sub

Sub Serge_007()
     Dim wb As Workbook, sh As Worksheet, arr
     Dim bookName As String, Strc As String
     Dim i As Long, j As Long, lastCol As Long
      
     bookName = "d:\0.xls"
     Application.ScreenUpdating = False
     Application.ShowWindowsInTaskbar = False
     Application.DisplayAlerts = False
     Rows("1:2").UnMerge
     lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
     Range("O1:R1").Value = Range("O2:R2").Value
     Rows("2:2").Delete Shift:=xlUp
      
     On Error GoTo error_S
     Set wb = GetObject(bookName)
     Set sh = wb.Sheets("Справочник")
     For Each sh In ThisWorkbook.Worksheets
         If sh.Name = "Справочник" Then sh.Delete
     Next
     wb.Sheets("Справочник").Copy After:=Sheets(Sheets.Count)
     wb.Close False: Set sh = Nothing: Set wb = Nothing
error_S:
     On Error GoTo 0
     Sheets("Рабочий").Activate

     arr = Sheets("Справочник").Range("A1").CurrentRegion.Value
     With CreateObject("Scripting.Dictionary")
         For i = 1 To UBound(arr)
             .Item(arr(i, 1)) = arr(i, 2)
         Next
         arr = Range(Cells(1, "S"), Cells(Rows.Count, lastCol).End(xlUp)).Value
         For i = 1 To UBound(arr)
             For j = 1 To UBound(arr, 2)
                 If .exists(arr(i, j)) Then
                     arr(i, j) = .Item(arr(i, j))
                 Else
                     Cells(i, 18 + j).Interior.Color = vbRed
                     Strc = Strc & "; " & Cells(i, 18 + j).Address
                 End If
             Next: Next
     End With
     Range(Cells(1, "S"), Cells(Rows.Count, lastCol).End(xlUp)) = arr
     Application.DisplayAlerts = True
     Application.ShowWindowsInTaskbar = True
     Application.ScreenUpdating = True
     If Len(Strc) Then MsgBox Mid$(Strc, 2)

End Sub