MyTetra Share
Делитесь знаниями!
Как удалить папку или все файлы из папки через VBA
03.01.2018
18:00
Текстовые метки: FileDialog,mso
Раздел: VBA - GetOpen

Как удалить папку или все файлы из папки через VBA

Предположим, что ежедневно во временную папку поступают файлы отчетов от филиалов. Они могут собираться из почты кодом вроде такого: Сохранить вложения из Outlook в указанную папку или добавляться в папку иными средствами. Далее Вы собираете данные из этих файлов неким кодом(вроде этого - Как собрать данные с нескольких листов или книг?). Но с каждым днем файлов все больше и больше и приходится заходить в папку и руками чистить её от лишних файлов, чтобы при сборе данных не приходилось каждый раз искать и отбирать только новые файлы.
Если надо удалять только конкретные файлы(например только файлы Excel, содержащие в имени слово "отчет"), то можно использовать такой код:

Sub Remove_AllFilesFromFolder() Dim sFolder As String, sFiles As String 'диалог запроса выбора папки с файлами 'подробнее про диалоги выбора папки или файла: ' http://www.excel-vba.ru/chto-umeet-excel/dialogovoe-okno-vybora-fajlovpapki/ 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) 'отбирать только файлы Excel, содержащие в имени слово "отчет" sFiles = Dir(sFolder & "*отчет*.xls*") 'цикл по всем файлам в папке On Error Resume Next Do While sFiles <> "" 'удаляем файл Kill sFolder & sFiles If Err.Number = 70 Then MsgBox "Невозможно удалить файл '" & sFiles & "'. Возможно файл открыт в другой программе или нет прав на удаление", vbCritical, "www.excel-vba.ru" Err.Clear End If 'на всякий случай передаем управление системе, 'чтобы дождаться удаления DoEvents 'получаем имя следующего файла в папке sFiles = Dir Loop End Sub


1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

Sub Remove_AllFilesFromFolder()

    Dim sFolder As String, sFiles As String

    'диалог запроса выбора папки с файлами

    'подробнее про диалоги выбора папки или файла:

    '       http://www.excel-vba.ru/chto-umeet-excel/dialogovoe-okno-vybora-fajlovpapki/

    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)

    'отбирать только файлы Excel, содержащие в имени слово "отчет"

    sFiles = Dir(sFolder & "*отчет*.xls*")

    'цикл по всем файлам в папке

    On Error Resume Next

    Do While sFiles <> ""

        'удаляем файл

        Kill sFolder & sFiles

        If Err.Number = 70 Then

            MsgBox "Невозможно удалить файл '" & sFiles & "'. Возможно файл открыт в другой программе или нет прав на удаление", vbCritical, "www.excel-vba.ru"

            Err.Clear

        End If

        'на всякий случай передаем управление системе,

        'чтобы дождаться удаления

        DoEvents

        'получаем имя следующего файла в папке

        sFiles = Dir

    Loop

End Sub

Чтобы удалять полностью все файлы в папке, но папку оставить, то строку sFiles = Dir(sFolder & "*отчет*.xls*") надо записать так: sFiles = Dir(sFolder & "*")

Если необходимо удалять файлы по дате создания/изменения(например, только файлы, созданные раньше 01.03.2017), то можно использовать такой код:

Sub Remove_FilesFromFolder_AfterDate() Dim sFolder As String, sFiles As String Dim dd As Date, dKill As Date 'задаем дату. Если файл был создан/изменен до этой даты - он будет удален dKill = CDate("01.03.2017") 'можно задать проще: dKill = #3/1/2017# 'диалог запроса выбора папки с файлами 'подробнее про диалоги выбора папки или файла: ' http://www.excel-vba.ru/chto-umeet-excel/dialogovoe-okno-vybora-fajlovpapki/ 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) sFiles = Dir(sFolder & "*") 'цикл по всем файлам в папке On Error Resume Next Do While sFiles <> "" 'получаем дату создания или изменения файла dd = FileDateTime(sFolder & sFiles) 'если дата файла меньше заданной для удаления(был создан раньше) If dd < dKill Then 'удаляем файл Kill sFolder & sFiles If Err.Number = 70 Then MsgBox "Невозможно удалить файл '" & sFiles & "'. Возможно файл открыт в другой программе или нет прав на удаление", vbCritical, "www.excel-vba.ru" Err.Clear End If 'на всякий случай передаем управление системе, 'чтобы дождаться удаления DoEvents End If 'получаем имя следующего файла в папке sFiles = Dir Loop End Sub


1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

Sub Remove_FilesFromFolder_AfterDate()

    Dim sFolder As String, sFiles As String

    Dim dd As Date, dKill As Date

    

    'задаем дату. Если файл был создан/изменен до этой даты - он будет удален

    dKill = CDate("01.03.2017") 'можно задать проще: dKill = #3/1/2017#

    'диалог запроса выбора папки с файлами

    'подробнее про диалоги выбора папки или файла:

    '       http://www.excel-vba.ru/chto-umeet-excel/dialogovoe-okno-vybora-fajlovpapki/

    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)

    sFiles = Dir(sFolder & "*")

    'цикл по всем файлам в папке

    On Error Resume Next

    Do While sFiles <> ""

        'получаем дату создания или изменения файла

        dd = FileDateTime(sFolder & sFiles)

        'если дата файла меньше заданной для удаления(был создан раньше)

        If dd < dKill Then

            'удаляем файл

            Kill sFolder & sFiles

            If Err.Number = 70 Then

                MsgBox "Невозможно удалить файл '" & sFiles & "'. Возможно файл открыт в другой программе или нет прав на удаление", vbCritical, "www.excel-vba.ru"

                Err.Clear

            End If

            'на всякий случай передаем управление системе,

            'чтобы дождаться удаления

            DoEvents

        End If

        'получаем имя следующего файла в папке

        sFiles = Dir

    Loop

End Sub

Если необходимо всегда удалять файлы, дата создания которых раньше текущей, то строку dKill = CDate("01.03.2017") нужно заменить на такую: dKill = Date. Если удалить надо файлы недельной давности, то: dKill = Date-7


Если же необходимо удалить папку полностью, а не только файлы в ней, то лучше использовать такой код:

Sub RemoveFolderWithContent() Dim sFolder As String, sFiles 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) 'путь к папке можно задать статично, если он заранее известен и не изменяется ' sFolder = "C:\temp\Ежедневные отчеты\10072017" 'путь к папке, которую надо удалить Shell "cmd /c rd /S/Q """ & sFolder & """" End Sub


1

2

3

4

5

6

7

8

9

10

11

12

Sub RemoveFolderWithContent()

    Dim sFolder As String, sFiles 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)

    'путь к папке можно задать статично, если он заранее известен и не изменяется

    '    sFolder = "C:\temp\Ежедневные отчеты\10072017" 'путь к папке, которую надо удалить

    Shell "cmd /c rd /S/Q """ & sFolder & """"

End Sub

Этот код удалить папку вместе со всеми файлами буквально за секунду.
Вообще в VBA есть специальная команда для удаления директорий(папок) RmDir. Но она способна удалить только пустую папку, поэтому редко когда можно найти её практическое применение. Если в файле есть хоть один файл то команда RmDir выдаст ошибку '75' - File/Path access error.

Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования