Ребятки, добрый вечер! Вынужден обратиться к вам за помощью. При помощи поиска я нашел необходимый мне код (он в модуле прилагаемого файла). Склеить сложные макросы не под силу.
Мне необходимо, чтобы путь который указывается в следующем виде
Const FLDR = "C:\Users\Евгеша\Desktop\Макросы\" ' указать путь
был заменен на возможность выбора нужной папки через ДИАЛОГОВОЕ ОКНО.
Sub Удаление_макросов() Const FLDR = "C:\Users\Евгеша\Desktop\Макросы\" ' указать путь Dim w, q If MsgBox("Внимание!!!" & vbLf & _ "Будут удалены ВСЕ компоненты VBA (макросы, формы, пользовательские функции) из ВСЕХ файлов Excel в папке " _ & FLDR & vbLf & "Продолжить?", vbCritical + vbYesNoCancel + vbDefaultButton2) <> vbYes Then Exit Sub Application.EnableEvents = False 'для запрещения макросов Workbook_Open в открываемых книгах w = Dir(FLDR & "*.xls*") 'фактически *.xls* Do While w <> "" With Workbooks.Open(FLDR & w)
'ActiveWorkbook.CheckCompatibility = False ' отключает проверку совместимости при сохранении этой книги
.Close DeleteAllVBA 'если компонентов VBA не было, закрыть без сохранения End With w = Dir Loop Application.EnableEvents = True End Sub
Самый лучший вариант, если этот макрос будет работать не только с файлами, размещенными в этой папке, а и с файлами, которые находятся в подпапках.
Const FLDR = "C:\Users\Евгеша\Desktop\Макросы\" ' указать путь
на код предложенный вами, однако VBA ругается и выделяет ".SelectedItems"
Уважаемый Юрий М, пробовал и поиском, уже голова не соображает ... все смешалось в винегрет, однако решить данную задачу у меня не получается ... но я стараюсь ... читаю вашу ссылку на поиск
Ребятки, продолжаю просить помощи ... Спасибо за переадресацию в поиск, мне удалось многое прочитать, однако решить свою задачу не по силам ... Ниже привожу мое произведение, понимаю, стыдно, но ... На сколько я понял перебор папок происходит, однако макрос не выполняет своего стратегического предназначения ... При чем перебор осуществляется почему-то в папке на уровень выше, нежели чем в папках которые содержаться внутри папки ... а может даже и несколько иначе ... Сложно понять ... Надеюсь на вашу помощь!
То, над чем ломаю голову не первый день:
Public k As Byte Public mmm As Byte Public zzz As Byte Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _ Optional ByVal SearchDeep As Long = 999) As Collection ' Получает в качестве параметра путь к папке FolderPath, ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением) ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются). ' Возвращает коллекцию, содержащую полные пути найденных файлов ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)
Set FilenamesCollection = New Collection ' создаём пустую коллекцию Set FSO = CreateObject("Scripting.FileSystemObject") ' создаём экземпляр FileSystemObject GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск Set FSO = Nothing: Application.StatusBar = False ' очистка строки состояния Excel End Function
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _ ByRef FileNamesColl As Collection, ByVal SearchDeep As Long) ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO ' перебор папок осуществляется в том случае, если SearchDeep > 1 ' добавляет пути найденных файлов в коллекцию FileNamesColl On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath) If Not curfold Is Nothing Then ' если удалось получить доступ к папке
' раскомментируйте эту строку для вывода пути к просматриваемой ' в текущий момент папке в строку состояния Excel ' Application.StatusBar = "Поиск в папке: " & FolderPath
For Each fil In curfold.Files ' перебираем все файлы в папке FolderPath
If UCase(fil.Name) Like "*" & UCase(Mask) Then FileNamesColl.Add fil.Path
'If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path Next SearchDeep = SearchDeep - 1 ' уменьшаем глубину поиска в подпапках If SearchDeep Then ' если надо искать глубже For Each sfol In curfold.SubFolders ' перебираем все подпапки в папке FolderPath GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep Next End If Set fil = Nothing: Set curfold = Nothing ' очищаем переменные End If End Function
Function DeleteAllVBA() As Boolean 'удаляет все компоненты VBA в текущей книге и возвращает True, если они были Dim i&, j& With ActiveWorkbook.VBProject For i = .VBComponents.Count To 1 Step -1 If .VBComponents(i).Type = 100 Then 'vbext_ComponentType.vbext_ct_Document, т.е. модуль книги, листа With .VBComponents(i).CodeModule j = .CountOfLines - .CountOfDeclarationLines If j Then .DeleteLines 1, .CountOfLines: DeleteAllVBA = True End With Else 'остальные типы: модуль, модуль класса, форма .VBComponents.Remove .VBComponents(i): DeleteAllVBA = True End If Next End With End Function
Sub Удаление_макросов_2() ' Ищем на рабочем столе все файлы TXT, и выводим на лист список их имён. ' Просматриваются папки с глубиной вложения не более трёх. Application.ScreenUpdating = False Dim coll As Collection, ПутьКПапке As String ' получаем путь к папке РАБОЧИЙ СТОЛ 'ПутьКПапке = "Y:\Otdel\1.ПОКУПКА\X-files\на списание\АСКУЭ\йОПТ\80020\На отправку\2010 год\08 август\с потеряшками" 'CreateObject("WScript.Shell").SpecialFolders("Desktop") With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = Application.DefaultFilePath & "\" .Title = "Укажите папку с файлами" If .Show = False Then Exit Sub Folder = .SelectedItems.Item(1) End With ПутьКПапке = Folder
' считываем в колекцию coll нужные имена файлов 'Set coll = FilenamesCollection(ПутьКПапке, ".xml", 3) 'ВОТ В ЭТОМ МЕСТЕ И ПРОИСХОДИТ ЗАГВОЗДКА
Dim w, q If MsgBox("Внимание!!!" & vbLf & _ "Будут удалены ВСЕ компоненты VBA (макросы, формы, пользовательские функции) из ВСЕХ файлов Excel в папке " _ & FLDR & vbLf & "Продолжить?", vbCritical + vbYesNoCancel + vbDefaultButton2) <> vbYes Then Exit Sub Application.EnableEvents = False 'для запрещения макросов Workbook_Open в открываемых книгах w = Dir(FLDR & "*.xls*") 'фактически *.xls* Do While w <> "" With Workbooks.Open(FLDR & w)
ActiveWorkbook.CheckCompatibility = False ' отключает проверку совместимости при сохранении этой книги
.Close DeleteAllVBA 'если компонентов VBA не было, закрыть без сохранения End With w = Dir Loop Application.EnableEvents = True End Sub
Поиск файлов, в имени которых встречается заданная строка, в указанной папке и ее подпапках. По результатам поиска создается список, в котором для каждого найденного файла выводится ссылка на файл, размер файла и дата его последнего изменения. Список помещается на рабочий лист "Результат поиска файлов". После выполнения макроса этот лист станет первым листом в рабочей книге.