Option Explicit
#If VBA7 Then
  Private Declare PtrSafe Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
#Else
  Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As Any, ByVal lpDefault As String,ByVal lpReturnedString As String, ByVal nSize As Long) As Long
#End If

Sub ZVI_FastPageSettings()
' ZVI:2024-04-28 https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=164667
' Ускорить код, задающий параметры печати

  Const ISDEBUG = 0   ' 0/1 for Ready/Debug

  Static sFolder As String
  Dim sFile As String, sPrnName As String, sXpsName As String, sBuf As String, sDevices() As String
  Dim vFileName As Variant, ActSheet As Variant
  Dim Ws As Worksheet
  Dim colFiles As Collection
  Dim i As Long, j As Long, t As Long

  ' Choose Folder
  If sFolder = vbNullString Then sFolder = ThisWorkbook.Path & "\"
  With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = sFolder
    .Title = "Выберите папку с XLS* для установки парамеров страниц"
    .Show
    If .SelectedItems.Count = 0 Then
      MsgBox "Обработка файлов отменена", vbExclamation, "Завершение"
      Exit Sub
    Else
      sFolder = .SelectedItems(1) & "\"
    End If
  End With

  ' Collect file names
  Set colFiles = New Collection
  sFile = Dir(sFolder & "*.XLS*", vbNormal)
  While sFile <> vbNullString
    colFiles.Add sFolder & sFile
    sFile = Dir()
  Wend
  If colFiles.Count = 0 Then
    MsgBox "Нет XLS* файлов в папке:" & vbLf & sFolder, vbExclamation, "Завершение"
    Exit Sub
  End If

  ' Save current printer name
  sPrnName = Application.ActivePrinter

  ' Temporary set up XPS printer
  If Not sPrnName Like "*XPS*" Then
    sBuf = String(2 ^ 14, Chr(0))
    i = GetProfileString("Devices", vbNullString, vbNullString, sBuf, Len(sBuf))
    sBuf = Left(sBuf, i)
    For Each vFileName In Split(sBuf, Chr(0))
      If vFileName Like "*XPS*" Then
        sXpsName = vFileName & " (Ne" & Right("00" & j, 2) & ":)"
        Application.ActivePrinter = sXpsName
        Exit For
      End If
      j = j + 1
    Next
  End If

  ' Disable screen blinking & events
  If Not ISDEBUG Then
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    On Error GoTo exit_
  End If

  ' Disable PrintCommunication
  Application.PrintCommunication = False

  ' Process XLS* files in the choosen folder
  j = 0
  i = colFiles.Count
  t = Timer
  For Each vFileName In colFiles
    With Workbooks.Open(vFileName, UpdateLinks:=False)
      j = j + 1
      Set ActSheet = .ActiveSheet
      Application.StatusBar = "Файл " & j & " из " & i & " : " & .Name
      Application.PrintCommunication = False
      For Each Ws In .Worksheets
        If Ws.Visible Then
          Ws.DisplayPageBreaks = False
          Ws.Activate
          ActiveWindow.View = xlNormalView
          With Ws.PageSetup
            .PaperSize = xlPaperA4
            .Orientation = xlPortrait
            .FitToPagesWide = 1
            .FitToPagesTall = False
          End With
        End If
      Next
      Application.PrintCommunication = True
      ActSheet.Activate
      .Close SaveChanges:=True
    End With
  Next
  t = Timer - t
  Application.StatusBar = False

  ' Restore previous active printer
  Application.ActivePrinter = sPrnName

exit_:

  ' Set NormalView in ActiveSheet
  ActiveWindow.View = xlNormalView
  ActiveSheet.DisplayPageBreaks = False
  
  ' Restore disabled settings
  Application.PrintCommunication = True
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  
  ' Show statistics/error
  If Err Then
    MsgBox Err.Description, vbCritical, "Ошибка: " & Err.Number
  Else
    MsgBox "Успешно обработано файлов: " & colFiles.Count _
         & " за " & t & " сек" & vbLf _
         & "В папке:" & vbLf & sFolder, vbInformation, "Завершение"
  End If

End Sub

Option Explicit

Dim dt As Date

Sub Create_Random()
' ZVI:2024-04-05 https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&TID=164251
  
  Const TimeLimit = "00:00:15" ' "hh:mm:ss"
  
  Dim a(), b()
  
  If dt > 0 Then
    MsgBox "Game is running, use Stop", vbExclamation, "Restart is blocked"
    Exit Sub
  End If
 
  ' Main
  With Лист1.Range("A1:B1").CurrentRegion.Resize(, 3)
    a() = .Value
    With .Columns(3)
      .Formula = "=RAND()"
      .Value = .Value
    End With
    .Sort .Cells(3), xlAscending, Header:=xlYes
    b() = .Value
    .Value = a()
  End With
  
  ' Write result
  Лист2.UsedRange.Offset(1).ClearContents
  Лист2.Range("A1:B1").Resize(UBound(a)).Value = b()
  
  ' Reset UsedRange
  With Лист1.UsedRange: End With
  With Лист2.UsedRange: End With
  
  ' Charge stop timer
  dt = Now + TimeValue(TimeLimit)
  Application.OnTime dt, "StopTheGame"
  
End Sub

Sub StopTheGame()
  If dt > 0 Then
    Application.OnTime Now, "Auto_Close"
    MsgBox "Game is over!", vbInformation, "Game Timer"
  End If
  Лист2.UsedRange.Offset(1).ClearContents
End Sub

Private Sub Auto_Close()
  On Error Resume Next
  If dt > 0 Then Application.OnTime EarliestTime:=dt, Procedure:="StopTheGame", Schedule:=False
  dt = 0
End Sub