Sub VlokopiroVanie()
Dim i As Long, f As Long, s As String, n As Long
    
    For i = 3 To 1000
        n = 1
        For f = 7 To 8
            Cells(i, f) = Application.VLookup(Cells(i, 2).Value, Range("X:Y"), n + 1, False)
            n = n + 1
        Next f
    Next i
    MsgBox "Complete!"
End Sub

Sub montero()

For n = 3 To ActiveSheet.UsedRange.Rows.Count

    Range("B" & n).Value = Worksheets("A").Range("A" & n).Value
    Range("D" & n).FormulaR1C1 = "=+MID('A'!R[-2]C[-1],5,2)&""/""&MID('A'!R[-2]C[-1],8,3)&""/""&R1C4"
    Range("E" & n).FormulaR1C1 = "=+MOD('A'!R[-2]C[-3],1)"
    Range("F" & n).Value = Worksheets("A").Range("D" & n).Value
    Range("G" & n).FormulaR1C1 = "=+VLOOKUP(RC[-6],base!R2C4:R200C6,3,0)"
    Range("H" & n).FormulaR1C1 = "=+VLOOKUP(RC[-7],base!R2C4:R200C5,2,0)"
    Range("I" & n).Value = Worksheets("A").Range("F" & n).Value
    Range("J" & n).Value = Worksheets("A").Range("H" & n).Value
    Range("K" & n).Value = Worksheets("A").Range("J" & n).Value
    Range("L" & n).Value = Worksheets("A").Range("K" & n).Value

Next n

End Sub

 Option Explicit

Sub SHEET_RENAME()
Dim s As String, fldr As String, j As Long, f As Long
Dim rc As Range
Dim wb As Workbook
Dim sh As Worksheet

fldr = "C:\Users\User\Desktop\777\"
s = Dir(fldr & "*.xlsx*")
j = 0
f = 0
Application.ScreenUpdating = False

' проверка существования файлов
Do While s <> ""
    s = Dir
    f = f + 1
Loop

' обработка
s = Dir(fldr & "*.xlsx*")
Do While s <> ""
    Set wb = Workbooks.Open(fldr & s)


    Set sh = GetSh(wb, Range("B5").Text, Range("B6").Text, Range("B7").Text, Range("B8").Text)


If Not sh Is Nothing Then
        ' изменение листов
        If sh.Visible = xlSheetVisible Then sh.Select
        sh.Name = "1"
        wb.RefreshAll
        wb.Save
        j = j + 1
    End If
    wb.Close False
    
    s = Dir
    Application.StatusBar = "Переименован(ы): " & j & " iz " & f & " failov" & " -> " & s: DoEvents
Loop

    Application.ScreenUpdating = True
    ActiveWorkbook.RefreshAll
    Application.StatusBar = "Переименован(ы): " & j & " из " & f & " failov"

End Sub

Private Function GetSh(wb As Workbook, ParamArray sheetNames() As Variant) As Worksheet
    Dim sh As Worksheet
    Dim vName As Variant
    On Error Resume Next
    For Each vName In sheetNames
        Set sh = wb.Sheets(vName)
        If Not sh Is Nothing Then
            Set GetSh = sh
            Exit For
        End If
    Next
    On Error GoTo 0
End Function

    Set sh = GetSh(wb, Range("B5").Text, Range("B6").Text, Range("B7").Text, Range("B8").Text)

Dim rng1 As Range

rng1.FormulaR1C1 = "=MID(RC[-1],1,2)&""/""&MID(RC[-1],4,2)&""/""&MID(RC[-1],7,4)"

for n = 2 to 1000

Rnge("B" & n)=rng1

next n

Sub Formating_Column()
Dim n As Variant
    Columns("B:D").Select
    Selection.Insert Shift:=xlToRight
    
For n = 2 To 10000
If Range("A" & n) = "" Then
    Range("B" & n) = ""
    Range("C" & n) = ""
    Range("D" & n) = ""
Else
    Range("B" & n).FormulaR1C1 = "=MID(RC[-1],1,2)&""/""&MID(RC[-1],4,2)&""/""&MID(RC[-1],7,4)"
    Range("C" & n).FormulaR1C1 = "=RIGHT(RC[-2],8"
    Range("D" & n).FormulaR1C1 = "=INT(RC[-2])"
    Range("B" & n) = Range("D" & n)
    Range("B" & n).NumberFormat = "m/d/yyyy"

End If
Next n
End Sub

Sub CombineWorkbooks()
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Sheets(1) 'вместо 1, можно указать "Лист1" например
    Dim wb1 As Workbook
    Dim ws1 As Worksheet
    Dim FilesToOpen
    Dim x As Integer
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    FilesToOpen = Application.GetOpenFilename _
                  (FileFilter:="Microsoft Excel Files (*.xlsx), *.xlsx", _
                   MultiSelect:=True, Title:="Files to Merge")
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Не выбрано ни одного файла!"
        GoTo ExitHandler
    End If
    x = 1
    While x <= UBound(FilesToOpen)
        Set wb1 = Workbooks.Open(Filename:=FilesToOpen(x)) 'присвоение на переменную объекта открываемой книги
        For Each ws1 In wb1.Worksheets 'перебор листов в открываемой книге
            i = ws.Cells(Rows.Count, 1).End(xlUp).Row 'последняя строка по 1 столбцу в этой книге
            i1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row 'последняя строка по 1 столбцу в открываемой книге книге
            If i1 > 1 Then 'если на листе есть чтото кроме шапки
                ws1.Rows("2:" & i1).Copy ws.Cells(i + 1, 1) 'вставить вместе с формулами
            End If
        Next ws1
        x = x + 1
    Wend
ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

Sub SHEET_RENAME()
Dim s As String, fldr As String, j As Integer, f As Integer
Dim rc As Range
fldr = Range("B3") ' путь
s = Dir(fldr & "*.xlsx*")
j = 0
f = 0
Application.ScreenUpdating = False

' проверка существования файлов 
Do While s <> ""
    s = Dir
    f = f + 1
Loop

' обработка
s = Dir(fldr & "*.xlsx*")
Do While s <> ""
    With Workbooks.Open(fldr & s)
        ' изменение листов
         Sheets("Sheet0").Select         ' МАТЕРИТСЯ ВОТ ЗДЕСЬ
         Sheets("Sheet0").Name = "1"
        .RefreshAll
        .Save
        .Close (True)
    End With
    s = Dir
    j = j + 1
    Application.StatusBar = "Переименован(ы): " & j & " iz " & f & " failov" & " -> " & s: DoEvents
Loop

    Application.ScreenUpdating = True
    ActiveWorkbook.RefreshAll
    Application.StatusBar = "Переименован(ы): " & j & " из " & f & " failov"

End Sub 

Private Sub CommandButton1_Click()
'Application.Worksheets("A").Activate
            NextRow = Application.WorksheetFunction.CountA(Range("A!A:A")) + 2
            
            Cells(NextRow, 1) = TextBox1.Text
End Sub

Sub mmm()
For n = 5 To 25
    For m = 5 To 15
If Worksheets("Report calculate").Cells(1, n) = Worksheets("Report calculate").Cells(n, m) Then
 Worksheets("Report calculate").Cells(n, m).Interior.Color = 4967
End If
Next m
Next n
End Sub

Application.Worksheets("A".Activate
            NextRow = Application.WorksheetFunction.CountA(Range("A:A") + 4
            Cells(NextRow, 1) = TextBox1.Text