Форум по VBA и MS Office

Sub макрос()

    Dim FN_folder As String, FNs As Collection, FilesNames As Collection
    Dim var, i As Long
   
   
    '1. Юзер выбирает папку с файлами.
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Выберите папку с файлами"
        If .Show = 0 Then
            Exit Sub
        End If
        FN_folder = .SelectedItems(1)
        ' Удаление правого слеша. Это если юзер выберет диск.
            ' Иначе макрос подставляет правый слеш и будет два слеша.
        If Right(FN_folder, 1) = "\" Then
            FN_folder = Left(FN_folder, Len(FN_folder) - 1)
        End If
    End With
   
    '2. Запись в коллекции полных имён (путь + имя) и имён ворд-файлов вида "##-##.##.## ".
    GetFNs FN_folder, FNs, FilesNames
   
    '3. Если файлов нет.
    If FNs.Count = 0 Then
        MsgBox "В выбранной папке нет нужных ворд-файлов.", vbExclamation
        Exit Sub
    End If
   
    '4. Проверка, что не открыты файлы из выбранной папки.
        ' Проверяется только юзер, который запустил макрос.
        ' Если файл открыт кем-то другим, то макрос этого не узнает.
    On Error Resume Next
    For i = 1 To Documents.Count
        ' Делаем бессмысленное действие, чтобы проверить, есть ли полное имя файла в коллекции.
            ' Другого способа проверить в майкрософте не придумали.
        If FNs(Documents(i).FullName) = "" Then
        End If
        If Err.Number = 0 Then
            MsgBox "Закройте этот файл, т.к. он находится в выбранной папке:" & vbCr & vbCr & _
                Documents(i).FullName, vbExclamation
            Exit Sub
        Else
            Err.Number = 0
        End If
    Next i
    On Error GoTo 0
   
    '5. Удаление файлов.
    For i = 1 To FNs.Count
   
        '1) Если это последний, то не удаляем его.
        If i = FNs.Count Then
            GoTo metka_NextFile
        End If
       
        '2) Копирование номера из имени файла в переменную "var".
            ' Переводим номер из типа "Текст" в тип "Число". чтобы
            ' можно было делать математические действия с ним.
        var = CDbl(Left(FilesNames(i), 2))
       
        '3) Если у файла номер "01", то не удаляем его.
        If var = 1 Then
            GoTo metka_NextFile
        End If
       
        '4) Если номер файла не кратен трём, то удаляем файл.
        If var Mod 3 <> 0 Then
            Kill FNs(i)
        End If
       
metka_NextFile:
    Next i
   
    '6. Сообщение.
    MsgBox "Готово.", vbInformation
   
End Sub

Private Sub GetFNs(FN_folder As String, FNs As Collection, FilesNames As Collection)

    ' Запись в коллекцию "FNs" полных имён (путь + имя) ворд-файлов вида "##-##.##.## ".
   
    Dim FileName As String
   
    Set FNs = New Collection
    Set FilesNames = New Collection
    FileName = Dir(FN_folder & "\*.doc*")
    ' Цикл по всем файлам, которые находятся в папке, которую выбрал юзер.
    Do While FileName <> ""
        ' Смотрим расширение файла.
        If (LCase(FileName) Like "*.doc") Or (LCase(FileName) Like "*.docx") Then
            ' Если у имени заданная структура.
            If FileName Like "##-##.##.## *" Then
                FNs.Add Key:=FN_folder & "\" & FileName, Item:=FN_folder & "\" & FileName
                FilesNames.Add Item:=FileName
            End If
        End If
        FileName = Dir
    Loop
   
End Sub