Sub SaveSheetsAsValues()
    Dim wb As Workbook
    Dim wsName As Worksheet
    Dim wsSource As Worksheet
    Dim newBook1 As Workbook
    Dim newBook2 As Workbook
    Dim i As Integer
    
    
    AccelerateBegin
    ' Указать активную книгу Excel с помощью надстройки
    Set wb = ActiveWorkbook
    
    ' Указать второй лист для извлечения названий
    Set wsName = wb.Sheets(2)
    
    ' Получить название для новых книг
    Dim fileName1 As String
    Dim fileName2 As String
    fileName1 = wsName.Range("A1").Value
    fileName2 = wsName.Range("B1").Value
    
    ' Создать новые книги Excel для четвертого и пятого листов
    Set newBook1 = Workbooks.Add
    Set newBook2 = Workbooks.Add
    
    With wb
        ' Сохранить третий лист в первую новую книгу на первый лист с сохранением форматов и ширин столбцов
        Set wsSource = .Sheets(3)
        CopyRangeWithFormat wsSource.UsedRange, newBook1.Sheets(1).Range("A1")
        newBook1.Sheets(1).Name = wsSource.Name
        
        ' Сохранить четвертый лист во вторую новую книгу на первый лист с сохранением форматов и ширин столбцов
        Set wsSource = .Sheets(4)
        CopyRangeWithFormat wsSource.UsedRange, newBook2.Sheets(1).Range("A1")
        newBook2.Sheets(1).Name = wsSource.Name
        
        ' Добавить второй лист во вторую новую книгу
        newBook2.Sheets.Add After:=newBook2.Sheets(1)
        
        ' Сохранить пятый лист во вторую новую книгу на второй лист с сохранением форматов и ширин столбцов
        Set wsSource = .Sheets(5)
        CopyRangeWithFormat wsSource.UsedRange, newBook2.Sheets(2).Range("A1")
        newBook2.Sheets(2).Name = wsSource.Name
    End With
    
    ' Сохранить новые книги
    newBook1.SaveAs wb.Path & "\" & fileName1 & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    newBook2.SaveAs wb.Path & "\" & fileName2 & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    
    ' Закрыть новые книги
    newBook1.Close False
    newBook2.Close False
    
    AccelerateEnd
End Sub

Private Sub CopyRangeWithFormat(rngSource As Range, rngDestination As Range)
    rngSource.Copy
    rngDestination.PasteSpecial Paste:=xlPasteValues
    rngDestination.PasteSpecial Paste:=xlPasteColumnWidths
    rngDestination.PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False
End Sub

Private Sub AccelerateBegin()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.DisplayStatusBar = False
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False
End Sub

Private Sub AccelerateEnd()
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True
    Application.DisplayStatusBar = True
    Application.DisplayAlerts = True
    Application.AskToUpdateLinks = True
End Sub

Option Explicit


Sub Кнопка1_Щелчок()
    Dim rGame       As Range
    Dim aGame()
    Dim Dic As Object, Dic2 As Object
    Dim FinalDate    As Date
    Dim i As Long, n As Long, k As Long
    Dim sIgrok      As String
    Dim col
    
    Set rGame = ActiveSheet.ListObjects(1).DataBodyRange
    aGame = rGame.Value
    Set Dic = CreateObject("Scripting.Dictionary")
    With Dic
        .CompareMode = 1
        For i = 1 To UBound(aGame)
            sIgrok = aGame(i, 1)
            If Not .exists(sIgrok) Then .Add sIgrok, CreateObject("Scripting.Dictionary")
            .Item(sIgrok).Item(i) = aGame(i, 2)

        Next
    End With

    For i = 1 To UBound(aGame, 1)
        Set Dic2 = Dic.Item(aGame(i, 1))
        FinalDate = aGame(i, 2) - 60
        n = 0
        k = 0
        For Each col In Dic2.Items
            If CDate(col) <= aGame(i, 2) Then k = k + 1
            If CDate(col) <= aGame(i, 2) And CDate(col) > FinalDate Then n = n + 1

        Next
        aGame(i, 4) = n
        aGame(i, 3) = k
    Next
    rGame.Value = aGame
    Set Dic = Nothing
    Beep
    MsgBox "Пересчет закончен"
End Sub

Sub FindIncomingFolder()
    Dim objOutlApp As Object, oNSpace As Object, i As Long
    On Error Resume Next
    Set objOutlApp = GetObject(, "outlook.Application")
    If objOutlApp Is Nothing Then
        Set objOutlApp = CreateObject("outlook.Application")
    End If
    Set oNSpace = objOutlApp.GetNamespace("MAPI")
    For i = 1 To 100
        MsgBox i & " = " & oNSpace.GetDefaultFolder(i)
    Next
End Sub

Sub uuu()
    Dim rn          As Range
    Dim i As Long, lLastRow As Long

    lLastRow = Cells(Rows.Count, 1).End(xlUp).Row

    Set rn = Range(Cells(ActiveSheet.UsedRange.Row, 1), Cells(lLastRow, 1))


    For i = lLastRow To rn.Row Step -1
        If i > 1 Then If i = 3 And TypeName(Cells(i - 1, 1).Value) = "String" Then Rows(i - 1).EntireRow.Insert

        If i > 3 Then If TypeName(Cells(i, 1).Value) = "String" And Not TypeName(Cells(i - 3, 1).Value) = "String" Then Rows(i).EntireRow.Insert

    Next

End Sub

Sub uniq()
Dim varIn As Variant


varIn = Range("A1:A" & (Cells(Rows.Count, 1).End(xlUp).Row)) 'Диапазон для сбора значений

    ReDim varUnique(1 To UBound(varIn, 1) * UBound(varIn, 2))

    nUnique = 0
    For iInRow = LBound(varIn, 1) To UBound(varIn, 1)
        For iInCol = LBound(varIn, 2) To UBound(varIn, 2)

            isUnique = True
            For iUnique = 1 To nUnique
                If varIn(iInRow, iInCol) = varUnique(iUnique) Then
                    isUnique = False
                    Exit For
                End If
            Next iUnique

            If isUnique = True Then
                nUnique = nUnique + 1
                varUnique(nUnique) = varIn(iInRow, iInCol)
            End If

        Next iInCol
    Next iInRow

    ReDim Preserve varUnique(1 To nUnique)
    
    For Each sZnach In varUnique
        strUniq = strUniq & sZnach & ", "
    Next
    Cells(1, 2).Value = strUniq ' куда вывести массив
End Sub