Sub DeleteEmptySubfolders()
    Dim FSO, Folder, Subfolder As Object
    Dim FolderPath, UserName As String
    UserName = Environ("USERNAME")
    FolderPath = "C:\Users\UserName\Desktop\ÒÅÑÒ_\"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(FolderPath)

    For Each Subfolder In Folder.SubFolders
        If FSO.GetFolder(Subfolder.path).Files.Count = 0 Then
            Subfolder.Delete
        End If
    Next

    Set FSO = Nothing
    Set Folder = Nothing
    Set Subfolder = Nothing
End Sub

Sub HighlightDuplicates()

Dim rng, cell As Range

Set rng = ActiveWorkbook.Sheets("дубли").Range("A1:A100")

For Each cell In rng.Cells

    If Application.WorksheetFunction.CountIf(rng, cell.Value) > 1 And cell.Value <> "" Then

        cell.Offset(0, 1).Value = "дубль"

    End If

Next cell

End Sub

Sub Replace_in_XML()
Dim TheFolder, TheFiles, AFile
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set TheFolder = fso.GetFolder("C:\Users\Desktop\Каталог\") ' путь к каталогу с xml
Set TheFiles = TheFolder.Files
For Each AFile In TheFiles
ReadXML (AFile)
Next
End Sub
Sub ReadXML(af As String)
Dim xml_doc As New DOMDocument
Dim nde_test As IXMLDOMElement
xml_doc.Load af
For Each nde_test In xml_doc.SelectNodes("<value status=""0"">")
  Debug.Print nde_test.SelectSingleNode("<value>").Text
Next
End Sub

Option Explicit
 
Dim objFSO As Object, objFolder As Object, objFile As Object
Sub Get_XLS_from_SubFolders()
    Dim sFolder As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    GetSubFolders sFolder
    Set objFolder = Nothing
    Set objFSO = Nothing
    Application.ScreenUpdating = True
    MsgBox "Файлы 'выдернуты' из всех указанных каталогов", vbInformation, "Гарантирую!"
End Sub
Private Sub GetSubFolders(sPath)
    Dim sPathSeparator As String, sObjName, UserName As String
    Dim wb As Workbook
    UserName = Environ("USERNAME")
    If Dir("C:\Users\" & UserName & "\Desktop\ИТОГ\", vbDirectory) = "" Then
    MkDir "C:\Users\" & UserName & "\Desktop\ИТОГ\"
    End If
    If Dir("C:\Users\" & UserName & "\Desktop\ИТОГ\XLS\", vbDirectory) = "" Then
    MkDir "C:\Users\" & UserName & "\Desktop\ИТОГ\XLS\"
    End If
    Set objFolder = objFSO.GetFolder(sPath)
    For Each objFile In objFolder.Files
        If Replace(objFile.name, objFSO.GetBaseName(objFile), "") Like ".xls*" Then
            'On Error Resume Next
            objFSO.MoveFile objFolder & "\*.xls*", "C:\Users\admin\Desktop\ИТОГ\XLS\"
        End If
    Next
    For Each objFolder In objFolder.SubFolders
        GetSubFolders objFolder.Path & Application.PathSeparator
    Next
End Sub

Option Explicit
Public Sub Alltext_to_exell()
    Dim oFD As FileDialog
    Dim x, lf As Long
Application.DisplayAlerts = 0
    'назначаем переменной ссылку на экземпляр диалога
    Set oFD = Application.FileDialog(msoFileDialogFilePicker)
    With oFD 'используем короткое обращение к объекту
    'With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True 'мультивыбор
        .Title = "Выбрать TXT-профили" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Text files", "*.txt", 1 'добавляем возможность выбора текстовых файлов
        '.Filters.Add "Excel files", "*.xls*;*.xlsx", 2 'устанавливаем возможность выбора только файлов Excel
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию
        .InitialFileName = ThisWorkbook.Path & "\" 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна
        If .Show = 0 Then Exit Sub 'показывает диалог
        'цикл по коллекции выбранных в диалоге файлов
        For lf = 1 To .SelectedItems.Count
            x = .SelectedItems(lf) 'считываем полный путь к файлу
            Workbooks.Open x 'открытие книги
        Next
    End With
Application.DisplayAlerts = -1
End Sub

Sheets(ActiveSheet.Index + 1).Select 'на следующий Лист
Sheets(ActiveSheet.Index - 1).Select 'на один Лист назад

Sub Разделить_по_книгам()
    Dim oDic As Object, arrData(), arrSeparateItems(), arrTemp(), i&, n&, m&, k&
 
    If MsgBox("Разделить данные по книгам?", vbQuestion + vbYesNo, "Вопрос") = vbNo Then Exit Sub
    Application.ScreenUpdating = False
    arrData() = Range("A1").CurrentRegion.Value
    Set oDic = CreateObject("Scripting.Dictionary")
    For i = LBound(arrData) To UBound(arrData)
        If Not oDic.exists(arrData(i, 1)) Then oDic.Add arrData(i, 1), arrData(i, 1)
    Next i
    arrSeparateItems() = oDic.items
    For n = LBound(arrSeparateItems) To UBound(arrSeparateItems)
        ReDim arrTemp(1 To UBound(arrData), 1 To UBound(arrData, 2))
        k = 0
        For i = LBound(arrData) To UBound(arrData)
            If arrData(i, 5) = arrSeparateItems(n) Then
                k = k + 1
                For m = LBound(arrData, 2) To UBound(arrData, 2)
                    arrTemp(k, m) = arrData(i, m)
                Next m
            End If
        Next i
        Workbooks.Add
        Range("A1").Resize(UBound(arrTemp), UBound(arrTemp, 2)).Value = arrTemp
        Columns("A:E").AutoFit
        Columns("B:B").HorizontalAlignment = xlLeft
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Right(arrSeparateItems(n), 10), xlExcel8
        ActiveWorkbook.Close SaveChanges:=True
    Next n
    Application.ScreenUpdating = True
    MsgBox "Данные разделены и сохранены в " & ThisWorkbook.Path & "\", vbInformation, "Конец"
End Sub

Sub Bloknot1()
'
Dim ReturnValue

    Sheets("Лист1").Select
    Range("E7:E20").Select
    Selection.Copy
'
ReturnValue = Shell("C:\Windows\system32\notepad.exe C:\Users\Papa\Desktop\Пустой.txt")

End Sub