Sub getInfoDrive() 
    Dim fso As Object, t As String
    Dim myDrive As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set myDrive = fso.GetDrive(fso.GetDriveName(sFolder)) 'sFolder Public variable 
    'Set myDrive = fso.GetDrive("P:") ' test string
    Select Case myDrive.DriveType
        Case 0: t = "Unknown"
        Case 1: t = "Removable drive (USB/SDCard)"
        Case 2: t = "Fixed"
        Case 3: t = "Network"
        Case 4: t = "CD-ROM"
        Case 5: t = "RAM Disk"
    End Select
Cells(2, 1) = t
Cells(2, 2) = myDrive.VolumeName
Cells(2, 3) = myDrive.FileSystem
Cells(2, 4) = myDrive.TotalSize '  &vbCrLf
'Cells(2, 4) = myDrive.FreeSpace
Cells(2, 5) = myDrive.TotalSize - myDrive.AvailableSpace

    Application.Run "getInfoFolder"

End Sub

Sub GetFolderDialog_Shell()
    On Error Resume Next
    Dim objShellApp As Object, objFolder As Object, ulFlags As Integer
    Set objShellApp = CreateObject("Shell.Application")
    ulFlags = 20
    Set objFolder = objShellApp.BrowseForFolder(0, "Error", ulFlags, "*:\") '"
    sFolder = objFolder.Self.Path 'folder path -> variable

    If Err.Number <> 0 Then
        MsgBox "File not found!", vbInformation, "File Information Program"
    
    Else:
    Application.Run "getInfoDrive"
    Application.Run "GetSerialDisk"
    
    End If
End Sub

Public Sub TabNExchange()
    Dim pConn As Object, sName As String, sTabel As String, sSQL As String, sCommandText As String
    sName = Worksheets("Работник").Range("F9")
    sTabel = InputBox("Введите таб.N " & sName, 1)
    sCommandText = "UPDATE [TBN$] SET TabelN ='" + sTabel & "' WHERE Rabotnik ='" + sName & "'"
    Set pConn = CreateObject("ADODB.Connection")
    pConn.Open "DBQ=\\Server\FTP\rabtab.xlsm;Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};ReadOnly=0;"
    sSQL = sCommandText
    MsgBox (sSQL) 'проверяем строку запроса SQL
    pConn.Execute sSQL, 128
    pConn.Close
    Set pConn = Nothing
End Sub

Sub SearhFiles() 'Макрос поиска файла с именем и автоматическое его открытие при наличии
     On Error GoTo err_: Workbooks.Open "\\Server\FTP\Global\" & Range("F2") & ".xls": Exit Sub 
err_:     MsgBox "Нет такого файла!" 
Application.Run "DOC-Fish.xlsm!R_to_xls" 'Запуск макроса по созданию файла с именем 
End Sub  

Sub R_to_xls()     
Const Path = "\\Server\FTP\Global\"  'Объявляем путь для сохранен
Dim NameDate As String    'Вводим переменную для определения даты для имени файла     
Dim RepFileName As String 'Вводим переменную для имени файла     
NameDate = Format((Sheets("Расход").Range("Y1")), "yyyy-mm-dd") 'Указываем значение переменной даты для имени файла (хотя дата не создаётся почему-то в имени)     
RepFileName = "R-" & NameDate & ".xls"   'Указываем значение переменной всего имени файла        
Sheets("Расход").Select     
Range("O2:AB41").Select     
Range("O2:AB41").Activate     
Selection.Copy     
Workbooks.Add     
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _     
xlNone, SkipBlanks:=False, Transpose:=False     
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _     
SkipBlanks:=False, Transpose:=False     
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _         
SkipBlanks:=False, Transpose:=False     
Sheets("Лист1").Select     
Sheets("Лист1").Name = "R-" & NameDate     
ActiveWindow.Zoom = 100     
ActiveWorkbook.SaveAs FileName:=Path & RepFileName, FileFormat _  
   :=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _    
     False, CreateBackup:=False 
End Sub

Sub CopySheet()
Dim Ws As Worksheet
Set Ws = ActiveSheet
With Workbooks("\\Server\ftp\Global\" & Range("Q3") & ".xls")
Err.Clear
On Error Resume Next
.Worksheets.Add After:=.Worksheets(Sheets.Count)
If Err.Number = 0 Then ActiveSheet.Name = Ws.Name
Ws.Parent.Activate
Cells.Copy Destination:=.Worksheets(ActiveSheet.Name).Cells
End With
End Sub

Sub SearhFiles() 'Макрос поиска файла с именем и автоматическое его открытие при наличии
On Error GoTo err_: Workbooks.Open "\\Server\777\S\" & Range("F2") & ".xls": Exit Sub
err_:     MsgBox "Нет такого файла!"
Application.Run "DOC.xlsm!Upload" 'Запуск макроса по созданию файла с именем
End Sub

Range("A10").Select
    Selection.NumberFormat = "@"
End Sub