Option Explicit
Sub Ins_Price()

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Articul, WB_Name, WS_Name, Data_Base_Goods As String
Dim RabRow, RabColumn, RabLsRow, ColumnIns, ir As Integer
Dim BP As Variant
Dim SQ As String
Dim iDBG, LDBG As Long
WB_Name = ActiveWorkbook.Name
WS_Name = ActiveSheet.Name

Data_Base_Goods = "D:\Data_Base_Goods.xlsb"
If Dir(Data_Base_Goods, vbDirectory) <> "" Then
Workbooks.Open Data_Base_Goods, ReadOnly:=True, UpdateLinks:=False
Data_Base_Goods = ActiveWorkbook.Name
LDBG = Cells(1, 6).Value + 2
Else
MsgBox "Что-то сломалось :(Обратитесь к администратору!", vbCritical
Exit Sub
End If

Workbooks(WB_Name).Activate
Worksheets(WS_Name).Activate

Set Articul = Cells.Find("Артикул*", , xlValues)
RabRow = Articul.Row
RabColumn = Articul.Column
RabLsRow = Cells(Rows.Count, RabColumn).End(xlUp).Row

ColumnIns = InputBox("Укажите номер столбца для вставки цены.")

For ir = RabRow To RabLsRow
    If CStr(Cells(ir, RabColumn).Value) Like "Арт*" Then
        SQ = Cells(ir, RabColumn).Value
            For iDBG = 2 To LDBG
                If SQ = Workbooks(Data_Base_Goods).Worksheets(1).Cells(iDBG, 1).Value Then
                    Workbooks(WB_Name).Worksheets(WS_Name).Cells(ir, ColumnIns).Value = Workbooks(Data_Base_Goods).Worksheets(1).Cells(iDBG, 6).Value
                    'BP = Workbooks(Data_Base_Goods).Worksheets(1).Cells(iDBG, 6).Value2
                    'Workbooks(WB_Name).Worksheets(WS_Name).Cells(ir, ColumnIns).Value2 = BP
                    iDBG = LDBG
                End If
            Next iDBG
    End If
Next ir

Application.CutCopyMode = False
Workbooks(Data_Base_Goods).Close SaveChanges:=False

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub