MyTetra Share
Делитесь знаниями!
Как удалить папку или все файлы из папки через VBA
Время создания: 16.03.2019 23:43
Текстовые метки: FileDialog, mso
Раздел: !Закладки - VBA - GetOpen
Запись: adgaver/mytetra_base_New/master/base/15149916377i4bonbr3q/text.html на raw.githubusercontent.com

Как удалить папку или все файлы из папки через 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.55
Яндекс индекс цитирования