Sub Test()

    Sheets("Закупки").Select
    ActiveSheet.AutoFilterMode = False
    ActiveSheet.ListObjects("Закупки").Range.AutoFilter Field:=52, Criteria1:="error"
      
    If ActiveSheet.ListObjects("Закупки").Range.SpecialCells(xlCellTypeVisible).Count > 0 Then
        MsgBox "Ошибка себ-ти Закупки"
        Exit Sub
    Else
        ActiveSheet.ShowAllData

    End If
    
    Sheets("Продажи").Select
    ActiveSheet.AutoFilterMode = False
    ActiveSheet.ListObjects("Продажи").Range.AutoFilter Field:=38, Criteria1:="error"
    If ActiveSheet.ListObjects("Продажи").Range.SpecialCells(xlCellTypeVisible).Count > 0 Then
        MsgBox "Ошибка себ-ти Продажи"
        Exit Sub
    Else
        ActiveSheet.ShowAllData
    End If


End Sub

    ThisWorkbook.Activate
    Sheets("for csv").Select
    Range("D5").Select
    ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
    Application.CalculateUntilAsyncQueriesDone
    
    Range("B5:Z5").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Workbooks.Add
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
    Columns("M:N").Select
    Selection.NumberFormat = "dd.mm.yyyy"
    Columns("S:S").Select
    Selection.NumberFormat = "0.00"
    Range("A1").Select
    
    File_name_for_save = Workbooks("PRICE LIST upload.xlsm").Sheets("for csv").Range("A1").Value
    
    With Application.FileDialog(msoFileDialogSaveAs)
        .InitialFileName = File_name_for_save
        If .Show = 0 Then Exit Sub
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Filename:=File_name_for_save
        Application.DisplayAlerts = True
    End With
    
    'ActiveWorkbook.SaveAs Filename:=File_name_for_save, FileFormat:=xlText, CreateBackup:=False
    'ActiveWorkbook.Close

BMdata = "https://eu001-sp.shell.com/:x:/r/sites/AAAAA9296/mytmnw/emea/ruscee/xxxxxxxxx..."

Workbooks.Open BMdata

Set bookList = Workbooks.Open(FileItem)
    Application.CalculateUntilAsyncQueriesDone
For Each sSheet In ActiveWorkbook.Sheets
    If sSheet.Name = "Deal for pricing_Direct" _
    Or sSheet.Name = "Main" _
    Or sSheet.Name = "SAM_Direct" _
    Or sSheet.Name = "AUREUS DEAL" _
    Or sSheet.Name = "DEAL HEADER" _
    Or sSheet.Name = "DirCust+AM" _
    Or sSheet.Name = "GUARDRAILS by Sold-to" _
    Or sSheet.Name = "Product Data" _
    Or sSheet.Name = "LPC" _
    Or sSheet.Name = "FX&STL&Dist" _
    Or sSheet.Name = "PL_new" _
    Or sSheet.Name = "rules" _
    Then
    Else
        sSheet.Copy After:=Workbooks(sModel).Sheets(Workbooks(sModel).Sheets.Count)
    End If
Next

Sub Macro1()
    
    Dim lClmn As Long
    lClmn = Cells(5, Columns.Count).End(xlToLeft).Column
    Rng = Cells(6, lClmn)
    Range("X6").Select
    ActiveCell.FormulaR1C1 = "=R4C&"" : ""&R5C"
    Cells(6, 23).AutoFill Destination:=Cells(6, 23).Resize(Cells(6, lClmn).End(xlToLeft).Column - 1)
                        
End Sub

Sub test()

Dim sSheetName As String
Dim a As Integer

sSheetName = ThisWorkbook.Sheets("Main").Cells(2, 20).Value 'T2

If sSheetName = "" Then Exit Sub
    On Error Resume Next
        
    For i2 = 1 To Worksheets.Count
        If InStr(Worksheets(i2).Name, sSheetName) > 0 Then
        Worksheets(i2).Name = sSheetName & "_old"
    End If
Next i2

If sSheetName & "_old" = "" Then Exit Sub
    On Error Resume Next
        
    For i3 = 1 To Worksheets.Count
        If InStr(Worksheets(i3).Name, sSheetName & "_old") > 0 Then
        Worksheets(i3).Name = sSheetName & "_old" & Worksheets(sSheetName & "_old").Count
    End If
Next i3

    Worksheets.Add.Name = sSheetName
    Sheets(sSheetName).Move After:=ThisWorkbook.Sheets("DealList")

End Sub

    ThisWorkbook.Activate
    Sheets("Project for pricing").Visible = True
    Sheets("Project for pricing").Select
    ActiveSheet.ListObjects("ShiptoProject").Range.AutoFilter Field:=3, Criteria1:="<>"
    ActiveSheet.ListObjects("ShiptoProject").Range.AutoFilter Field:=7, Criteria1:="-"
    Range("ShiptoProject[['# Ship-to]:[Segment]]").Select
    Selection.Copy
    
    Workbooks.Open Filename:="C:\Apps\My Daily Work\Pricing Analyst Team\SENSITIVITY MODEL\for SAM.xlsx", WriteResPassword:="qwerty", IgnoreReadOnlyRecommended:=True, UpdateLinks:=3
    
    Windows("for SAM.xlsx").Activate
    lastrow_Inv2 = Sheets("Projects").Cells(Rows.Count, 1).End(xlUp).Row + 1
    Sheets("Projects").Range("A" & lastrow_Inv2).PasteSpecial xlPasteValues

    ThisWorkbook.Activate
    Sheets("Project for pricing").Visible = True
    Sheets("Project for pricing").Select
    ActiveSheet.ListObjects("ShiptoProject").Range.AutoFilter Field:=7, Criteria1:="-"
    ActiveSheet.ListObjects("ShiptoProject").Range.AutoFilter Field:=3, Criteria1:="<>"
    
    Range("ShiptoProject[['# Ship-to]:[Segment]]").SpecialCells(xlCellTypeVisible).Copy
    
    Workbooks.Open Filename:="C:\Apps\My Daily Work\Pricing Analyst Team\SENSITIVITY MODEL\for SAM.xlsx", WriteResPassword:="qwerty", IgnoreReadOnlyRecommended:=True, UpdateLinks:=3
    
    Windows("for SAM.xlsx").Activate
    lastrow_Inv2 = Sheets("Projects").Cells(Rows.Count, 1).End(xlUp).Row + 1
    Sheets("Projects").Range("A" & lastrow_Inv2).PasteSpecial xlPasteValues

Sub Send_Mail()

    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody1 As String, sBody2 As String, sBody3 As String, sTable As String, sAttachment As String, sCC As String
 
    Application.ScreenUpdating = False
    On Error Resume Next
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    
    Set objMail = objOutlookApp.CreateItem(0)
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
 
    sTo = Range("Q2").Value
    sCC = ""
    sSubject = Range("Q4").Value
    sBody1 = Range("C5").Value
    sBody2 = Range("C6").Value
    sBody3 = Range("C12").Value
    sTable = Range("C18:J22").Value
 
    With objMail
        .To = sTo
        .CC = ""
        .Subject = sSubject
        .body = sBody1
        .body = sBody2
        .body = sBody3
        .Table = sTable
        '.HTMLBody = sBody
        .Attachments.Add ActiveWorkbook.FullName
        .Display 'Send
    End With
 
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
    
MsgBox ("DONE")
End Sub

    Dim LastRow As Long, i As Long
    LastRow = Cells(Rows.Count, "M").End(xlUp).Row
    For i = LastRow To 2 Step -1
        If Cells(i, "M").Value <> "" Then Rows(i).Delete
    Next

i = 2
Set dirObj = mergeObj.Getfolder("C:\Users\......")
Set filesObj = dirObj.Files
For Each everyObj In filesObj
Set bookList = Workbooks.Open(everyObj)

... часть макроса с копированием строк

Dim fileName As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
fileName = fso.GetFilename(everyObj)


Workbooks("Quarter brandmap macro_test.xlsm").Sheets("copied").Range("AQ" & i).Value = fileName
Application.DisplayAlerts = False

bookList.Close
i = Cells(Rows.Count, 1).End(xlUp).Row + 1
Next

Sub FillInNotifNew()

Sheets("For Notif (new)").Select

Dim wdApp As Object
Dim wdDoc As Object

HomeDir$ = ThisWorkbook.Path

Set wdApp = CreateObject("Word.Application")
I% = 2

Do
If Cells(I%, 1).Value = "" Then Exit Do
If Cells(I%, 1).Value <> "no" Then

NPP$ = Cells(I%, 1).Text

' äëÿ çàïîëíåíèÿ óâåäîìëåíèÿ
CustomerNameFull$ = Cells(I%, 5).Text
ContractNumber$ = Cells(I%, 6).Text
ContractDate$ = Cells(I%, 7).Text
TermAgreemDate$ = Cells(I%, 8).Text
NotifDate$ = Cells(I%, 9).Text
Distributor$ = Cells(I%, 10).Text
Bonus$ = Cells(I%, 11).Text
Points$ = Cells(I%, 12).Text
AmountWritten$ = Cells(I%, 13).Text
POA$ = Cells(I%, 14).Text
BonPeriod$ = Cells(I%, 17).Text

' äëÿ íàçâàíèÿ ôàéëà
PeriodForFile$ = Cells(I%, 15).Text
ContractForFile$ = Cells(I%, 16).Text
CustomerForFile$ = Cells(I%, 4).Text

FileCopy HomeDir$ + "\template_new.docx", HomeDir$ + "\" + "Bonus Lease (" + ContractForFile$ + ") - " + CustomerForFile$ + "_ " + PeriodForFile$ + ".docx"
Set wdDoc = wdApp.Documents.Open(HomeDir$ + "\" + "Bonus Lease (" + ContractForFile$ + ") - " + CustomerForFile$ + "_ " + PeriodForFile$ + ".docx")

wdDoc.Range.Find.Execute FindText:="&CustomerNameFull", ReplaceWith:=CustomerNameFull$
wdDoc.Range.Find.Execute FindText:="&ContractNumber", ReplaceWith:=ContractNumber$
wdDoc.Range.Find.Execute FindText:="&ContractDate", ReplaceWith:=ContractDate$
wdDoc.Range.Find.Execute FindText:="&TermAgreemDate", ReplaceWith:=TermAgreemDate$
wdDoc.Range.Find.Execute FindText:="&NotifDate", ReplaceWith:=NotifDate$
wdDoc.Range.Find.Execute FindText:="&Distributor", ReplaceWith:=Distributor$
wdDoc.Range.Find.Execute FindText:="&Bonus", ReplaceWith:=Bonus$
wdDoc.Range.Find.Execute FindText:="&Points", ReplaceWith:=Points$
wdDoc.Range.Find.Execute FindText:="&AmountWritten", ReplaceWith:=AmountWritten$
wdDoc.Range.Find.Execute FindText:="&POA", ReplaceWith:=POA$
wdDoc.Range.Find.Execute FindText:="&BonPeriod", ReplaceWith:=BonPeriod$

wdDoc.Save
wdDoc.Close

End If

I% = I + 1
Loop

wdApp.Quit

MsgBox "Ãîòîâî!"

End Sub

    Dim LastRow As Long, i As Long
    LastRow = Cells(Rows.Count, "F:F").End(xlUp).Row
    For i = LastRow To 2 Step -1
    If Cells(i, "F:F") = "" Then End
    Next

 sPath = ThisWorkbook.Path & "\" & RepPeriod & "\"
.SaveAs sPath & "BDF Report_" & RepPeriod & "_" & Manager & ".xlsx"

Sub Copy_Data()

    Dim bk_src As Workbook, bk_res As Workbook, sh_res As Worksheet
    Set bk_src = Workbooks("Book1.xlsm")
    Set bk_res = Workbooks("Book2.xlsm")
    sh_res.Name = Workbooks("Book1.xlsm").Worksheets("Macro").Range("E6").Value
    sh_src.UsedRange.Offset(1, 0).Copy sh_res.[A1].End(xlDown)(2)
    
MsgBox ("INCOICES DOWNLIADING - Compleat!")

End Sub

sh_res.Name = Workbooks("Book1.xlsm").Worksheets("Macro").Range("E6").Value

Sub Check()

    Dim LastRow As Long, i As Long
    LastRow = Cells(Rows.Count, 13).End(xlUp).Row
    For i = LastRow To 2 Step -1
    If Cells(i, 13) = "error" Then MsgBox "!!! #N/A in ServRendDate !!!"
    Range("M1").Select
    Next
End Sub

Sub AddCopy()

    Windows("Book1").Activate
    Sheets("Invoices").Select
    Cells.Select
    Selection.Copy
    Windows("Book2.xlsm").Activate
    
    Sheets.Add(Before:=Worksheets("Sold-to for report")).Name = Workbooks("Book1.xlsm").Worksheets("Sheet1").Range("E5")
    
    Sheets(Workbooks("Book1.xlsm").Worksheets("Sheet1").Range("E5")).Select
    Cells.Select
    ActiveSheet.Paste
    Windows("Book1.xlsm").Activate
    Sheets("Sheet1").Select
    Range("A1").Select

End Sub

Sub Macro2()
Sheets("Sheet2").[A1].CurrentRegion.Offset(1).Copy Sheets("Sheet1").[A1].End(xlDown)(2)
End Sub