Set WS = ThisWorkbook.Sheets("Отчёт")
Set WSK = WBK.Worksheets("Овощи")
LK = WSK.Range("C" & WSK.Rows.Count).End(xlUp).Row

For RK = 5 To LK
   
    If WS.Cells(LRK, "D") = WSK.Cells(RK, "C") Then
        WS.Cells(LRK, "Q") = WSK.Cells(RK, "BC")
        LRK=LRK+1
    End If
Next RK

PZ = ThisWorkbook.Sheets("Справка о динамике")
Arh = S.Open(p)
LR = PZ.Range("A" & PZ.Rows.Count).End(xlUp).Row
LRA = Arh.Range("A" & Arh.Rows.Count).End(xlUp).Row
For RZ = 5 To LRA
    S = Arh.Cells(RZ, "D")
If S = "Азербайджан" Then

Sub Backup_Active_Workbook()
    Dim x As String
    strPath = "C:\Desktop\Архив"     'папка для сохранения резервной копии
    On Error Resume Next
    x = GetAttr(strPath) And 0
    If Err = 0 Then ' если путь существует - сохраняем копию книги, добавляя дату
        strDate = Format(Now, "dd-mm-yy")
        FileNameXls = strPath & "\" & "Отчёт " & " " & strDate & ".xls"   'или xlsm
        ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
    Else 'если путь не существует - выводим сообщение
        MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical
    End If
End Sub

Dim OD As Workbook
Dim ODS As Worksheet
Dim TDS As Worksheet
Dim LR, RZ As String
Dim PT As String

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False

Set TDS = ThisWorkbook.Sheets("Свод)
LR = TDS.Range("A" & TDS.Rows.Count).End(xlUp).Row + 1

PT = Application.GetOpenFilename("Excel files(*.xls*),*.xls*, 2,", , True)
Set OD = Workbooks.Open(PT)
Set ODS = OD.Worksheets("Отчет")
'ODS.Unprotect "1234"

'-------------------------------------------
TDS.Cells(LR, "A") = ODS.Cells(6, "C")
TDS.Cells(LR, "B") = ODS.Cells(7, "C")
TDS.Cells(LR, "C") = ODS.Cells(15, "B")
TDS.Cells(LR, "D") = ODS.Cells(15, "E") 
TDS.Cells(LR, "E") = ODS.Cells(15, "C")
TDS.Cells(LR, "G") = ODS.Cells(9, "C")
TDS.Cells(LR, "H") = ODS.Cells(10, "C")
LR = LR + 1
TDS.Cells(LR, "A") = ODS.Cells(6, "C")
TDS.Cells(LR, "B") = ODS.Cells(7, "C")
TDS.Cells(LR, "C") = ODS.Cells(15, "B")
TDS.Cells(LR, "D") = ODS.Cells(15, "F") 
TDS.Cells(LR, "E") = ODS.Cells(15, "C")
TDS.Cells(LR, "G") = ODS.Cells(9, "C")
TDS.Cells(LR, "H") = ODS.Cells(10, "C")

Sub mydelite()

Dim WS As Worksheet
Dim RZ As Long
Dim LR As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False

Set WS = Workbooks("Справка").Sheets("Отчёт")
LR = WS.Range("B" & WS.Rows.Count).End(xlUp).Row

For RZ = 3 To LR
    If WS.Cells(RZ, "E") = " " Then
        Rows(RZ).EntireRow.Hidden = True
    RZ = RZ + 1
    End If
Next RZ

Application.Calculation = xlCalculationAutomatic
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True

End Sub

Sub serbius()

Dim WBO As Range
Dim WO As Workbook
Dim iLastRow As Long
Dim A As Range
Dim WD As Workbook

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False

Set WD = ThisWorkbook.Sheets("Ком. деятельность")

WBO = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", 2, "Выбрать Excel файлы", , True)

Workbooks(WBO).Sheets("Отчёт").Activate
Range("C7").Copy

WD.Sheets("Ком. деятельность").Activate
iLastRow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row

Set A = Cells(iLastRow + 1, 1)
A.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False
Application.ScreenUpdating = False

WO.Close True

End Sub

Sub Workbook_Open()
Dim arFiles, x, c As Range
Dim iLastRow As Long
Dim A As Range

Application.AskToUpdateLinks = False
Workbooks("Основной").Sheets("Расчёт").Range("A5:CO500").Clear

Workbooks.Open Filename:="тут указан путь"
Workbooks("Москва").Sheets("Расчёт").Range("CO5", Cells(Rows.Count, "A").End(xlUp)).Copy

Workbooks("Основной").Sheets("Расчёт").Activate
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row

Set A = Cells(iLastRow + 1, 1)
A.Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False
Application.ScreenUpdating = False
Workbooks("Москва").Close True

End Sub

Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetRow As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("D7:AK120"), Target)
xOffsetRow = 1
If Not WorkRng Is Nothing Then
    Application.EnableEvents = False
Dim r As Long
r = ActiveSheets.Cells(ActiveSheets.Rows.Count, "AL").End(xlToUp).Row+1
    For Each Rng In WorkRng

Workbooks("Страна").Sheets("Отчёт).Range("A5", Cells(Rows.Count, "CC").End(xlUp)).Copy

Workbooks.Open Filename:="\\vtk-kildushov\WG\!!! Портфель заказов\ПЗ Регион Африка.xlsx"
Workbooks("ПЗ Регион Африка").Sheets("Основной расчёт").Range("A5", Cells(Rows.Count, "I").End(xlUp)).Copy

Workbooks("ПЗ_факт+ожид — копия").Sheets("Основной расчёт").Activate
iLastRow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row

Set A = Cells(iLastRow + 1, 1)
A.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Application.CutCopyMode = False
Application.ScreenUpdating = False
Workbooks("ПЗ Регион Африка").Close True

Dim lLastRow As Long
Workbooks.Open Filename:="С\2022 \Отчёт\Отчёт.xlsm"

Workbooks("Авто.xls").Worksheets("Данные").Range("D8").copy

 With Workbooks("Отчёт.xlsm").Sheets("Коммерц")
       lLastRow = Cells(Rows.Count, 1).End(xlUp).Row

    Range("B" & lLastRow + 1).PasteSpecial (xlPasteValues)
End With

Set p=Sheets("Значения").Range("Список")
If Target.Cells.Count >1 Then Exit Sub
If IsEmpty(Target) Then Exit Sub
If not Intersect(Target,Range("A2:A10")) Is Nothing Then
If WorkSheetFunction.CountIf(p,Target)=0 Then
If not Intersect(Target, Sheets("Значения").Range("Список")) Then Target.Interior.Color=vbRed
End If
End If
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.Name = "LOG" Then Exit Sub
    Dim sLastValue As String
    Dim lLastRow As Long, wbLOG As Workbook
    Dim sPath As String
    Const sLOGName As String = "\LOG.xlsx"
    sPath = "C:\Users\Макс\Desktop"
    Application.ScreenUpdating = False
  
    '==============   только для записи в отдельный файл Excel ======================
    If Dir(sPath & sLOGName, vbDirectory) = "" Then
       Set wbLOG = Workbooks.Add
       wbLOG.SaveAs sPath & sLOGName, xlNormal
    End If
    Set wbLOG = Workbooks.Open(sPath & sLOGName)
    '============================================================================
    With wbLOG.Sheets(1)
        lLastRow = .Cells.SpecialCells(xlLastCell).Row + 1
        If lLastRow = .Rows.Count Then Exit Sub
        Application.ScreenUpdating = False: Application.EnableEvents = False
        .Cells(lLastRow, 1) = CreateObject("wscript.network").UserName
        .Cells(lLastRow, 2) = Format(Now, "dd.mm.yyyy HH:MM:SS")
        .Cells(lLastRow, 3) = Sh.Name
        .Cells(lLastRow, 4) = Target.Address(0, 0)
        .Cells(lLastRow, 5).NumberFormat = "@"
        .Cells(lLastRow, 5) = sValue
        If Target.Count > 1 Then
            Dim rCell As Range, rRng As Range
            On Error Resume Next
            Set rRng = Intersect(Target, Sh.UsedRange): On Error GoTo 0
            If Not rRng Is Nothing Then
                For Each rCell In rRng
                    If Not IsError(Target) Then sLastValue = sLastValue & "," & rCell Else sLastValue = sLastValue & "," & "Err"
                Next rCell
                sLastValue = Mid(sLastValue, 2)
            Else
                sLastValue = ""
            End If
        Else
            If Not IsError(Target) Then sLastValue = Target.Value Else sLastValue = "Err"
        End If
        .Cells(lLastRow, 6).NumberFormat = "@"
        .Cells(lLastRow, 6) = sLastValue
    End With
    wbLOG.Close 1
    Application.ScreenUpdating = True: Application.EnableEvents = True
End Sub
 
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.Name = "LOG" Then Exit Sub
    If Target.Count > 1 Then
        Dim rCell As Range, rRng As Range
        On Error Resume Next
        Set rRng = Intersect(Target, Sh.UsedRange): On Error GoTo 0
        If rRng Is Nothing Then Exit Sub
        For Each rCell In rRng
            If Not IsError(rCell) Then sValue = sValue & "," & rCell Else sValue = sValue & "," & "Err"
        Next rCell
        sValue = Mid(sValue, 2)
    Else
        If Not IsError(Target) Then sValue = Target.Value Else sValue = "Err"
    End If
End Sub