Option Explicit

Sub CreateFact()
Application.ScreenUpdating = False
Application.CutCopyMode = False
Application.DisplayAlerts = False

'***Копируем данные из входящих БДР***

'задаем путь к входящим БДР
Dim myPath As String
myPath = GetFolderPath
'Задаем часть имени файла - номер месяца
Dim Month As String
Month = Application.InputBox("Введите номер месяца", Type:=2)
'Задаем имя отчета о префакте
Dim BDR_f As Excel.Workbook
Set BDR_f = ThisWorkbook

'***********************************
'Вставляем БДР АСК
Dim filenameASK As String
filenameASK = myPath + "\" + Month + "_БДР_f_АСК.xlsx"

n = n + 1 / 2: p = 2 * n
Application.StatusBar = "Выполнено: " & n * 100 & "% " & String(p, ChrW(8700)): DoEvents

Workbooks.Open Filename:=filenameASK, UpdateLinks:=False
Workbooks(Month + "_БДР_f_АСК.xlsx").Worksheets("ФДР(USD)").Range("G9:WT253").Copy
BDR_f.Worksheets("АСК").Range("G10:WT254").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Workbooks(Month + "_БДР_f_АСК.xlsx").Close
'Вставляем БДР КРМ
Dim filenameKRM As String
filenameKRM = myPath + "\" + Month + "_БДР_f_КРМ.xlsx"

n = n + 1 / 2: p = 2 * n
Application.StatusBar = "Выполнено: " & n * 100 & "% " & String(p, ChrW(8700)): DoEvents

Workbooks.Open Filename:=filenameKRM, UpdateLinks:=False
Workbooks(Month + "_БДР_f_КРМ.xlsx").Worksheets("ФДР(USD)").Range("G9:WT253").Copy
BDR_f.Worksheets("КРМ").Range("G10:WT254").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Workbooks(Month + "_БДР_f_КРМ.xlsx").Close

Application.ScreenUpdating = True
Application.CutCopyMode = True
Application.DisplayAlerts = True
End Sub

Function GetFolderPath(Optional ByVal title As String = "Выберите папку", Optional ByVal initialPath As String = "c:\1\") As String
Dim PS As String: PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        If Not Right(initialPath, 1) = PS Then initialPath = initialPath & PS
        .ButtonName = "Выбрать": .title = title: .InitialFileName = initialPath
        If .Show <> -1 Then Exit Function
        GetFolderPath = .SelectedItems(1)
        If Not Right(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
End Function


Dim filenameQQQ As String

filenameFlot = myPath + "\" + Month + "_f_Товары.xlsx"

Workbooks.Open Filename:=filenameQQQ

Dim n As Single, p As Single

filenameASK = myPath + "\" + Month + "_БДР_f_АСК.xlsx"