Страницы: 1
RSS
Поиск файлов в папке и пересохранение этих файлов в новых папках с переименованием
 
Ребята, всем доброго времени суток! Прошу помощи вашей: требуется макрос, чтобы по списку из трёх ячеек брать наименование файла и по этому наименованию искать в папке макроса файл Эксель , а затем этот Эксель пересохранить в новую папку с названием по которому искали их, а сам файл переименовать (содержимое сохранить из файла который нашли).
грубо говоря из кучи файлов с уникальным наименованием искать нужный и сохранять в новую папку с наименованием файла и содержимым, а сам файл переименовать.
объем очень большой и нужно чтобы список закинул , а он из него по порядку брал наименование и искал файлы
очень рассчитываю на вашу помощь!!!
 
Цитата
Артем Медведев написал:
очень рассчитываю на вашу помощь!!!
а помощь в чем? Что конкретно не получается? Пока что больше похоже на "сделайте мне все с нуля". Если это действительно так, то либо ждите кому задачу из спортивного интереса захочется решить, либо обратитесь в ветку платных заказов...
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
В общем, мой вариант выглядит так: «представлено ниже». Суть в том, что по идее макрос должен брать значения из трёх ячеек, которые вместе составляю уникальное имя, далее по этому имени он должен в категории где лежит макрос начать поиск файла с частью уникального значения, после он должен его открыть и скопировать на новый лист текущей книги и сохранить в новую папку переименовав файл, однако вылезает ошибка на «next i» и я не дохожу мозгами что исправить...
Код
Sub Раскодить()
MsgBox "Как дела:)?", vbInformation, "Здоров, Димон:)"
InvoiceFolder$ = ThisWorkbook.Path
Dim allRange As Range
Set allRange = Range("AI11", Range("A11").End(xlDown))
Set ws1 = ThisWorkbook.Sheets("Лист1")
Set ws2 = ThisWorkbook.Sheets("Приложение №2")
For i = 1 To allRange.Rows.Count

     Dim coll As Collection
     Set coll = FilenamesCollection(InvoiceFolder$, allRange.Rows(i).Cells(4).Value & "_" & allRange.Rows(i).Cells(13).Value & "_" & allRange.Rows(i).Cells(21).Value & "_" & "*.xlsx", 1)
    If coll.Count = 0 Then
        MsgBox "Не найдено ни одной цепочки с данными ИНН в папке" & vbNewLine & InvoiceFolder$, _
               vbExclamation, "Нет необработанных цепочек"
        Exit Sub
    End If
    Dim WB As Workbook, sh As Worksheet, ra As Range
    For Each fileName In coll
    Set WB = Nothing: Set WB = Workbooks.Open(fileName, False, True)
 
        If WB Is Nothing Then    ' не удалось открыть файл
            Pi.Log vbTab & "ОШИБКА при загрузке файла. Файл не обработан."
 
        Else    ' файл успешно открыт
            Set sh = WB.Worksheets(1)    ' будем брать данные с первого листа
            ' берем диапазон ячеек с ячейки a1 до последней заполненной в столбце a
            Set ra = sh.Range(sh.Range("a1"), sh.Range("a" & sh.Rows.Count).End(xlUp))
 
            ' ==== переносим данные в наш файл (shb - кодовое имя листа, куда помещаем данные)
            ws2.Range("a1" & shb.Rows.Count).End (xlUp)
            Application.WorksheetFunction.Transpose (ra.Value)
            ' ==== конец обработки данных из очередного файла
    
    End If
    
    
    SaveAsFile "Приложение № 2 к Регламенту" & ".xlsx", allRange.Rows(i).Cells(4).Value & "_" & allRange.Rows(i).Cells(13).Value & "_" & allRange.Rows(i).Cells(21).Value & "_" & i
Next i
MsgBox "Генерация файлов завершена"
End Sub
 
Господи, почему оно так криво вставилось... все же нормально было((( а нет, нормально встало
Изменено: Артем Медведев - 27.07.2020 09:26:53
 
Артем Медведев у вас в коде есть строка
Код
For Each fileName In coll

но для неё нет
Код
Next fileName 

Добавьте её перед строкой
Код
SaveAsFile "Приложение № 2 к Регламенту"

До конца протестировать не мог, так как у вас коде есть функции, процедуры FilenamesCollection, SaveAsFile, которых в вашем коде не хватает.
 
Спасибо, сейчас попробую!  Сейчас файл пока не получится скинуть, на работе просто... подскажите , ещё для invoicefolder$ = thisworkbook.path вылезает ошибка и выделяет invoicefolder$ И пишет что не может найти его определение, как правильно и где лучше вставить его, как его определить? Я просто только постигаю эти науки...
 
Вот я её перенёс эту строку, у меня макрос нормально запускается (компилируется) и эта строка с invoicefolder нормально проходит
Код
Sub Раскодить()

    Dim allRange As Range
    Dim WB As Workbook, sh As Worksheet, ra As Range

    InvoiceFolder$ = ThisWorkbook.Path

    Set allRange = Range("AI11", Range("A11").End(xlDown))
    Set ws1 = ThisWorkbook.Sheets("Лист1")
    Set ws2 = ThisWorkbook.Sheets("Приложение №2")

    For i = 1 To allRange.Rows.Count
        Dim coll As Collection
        Set coll = FilenamesCollection(InvoiceFolder$, allRange.Rows(i).Cells(4).Value & "_" & allRange.Rows(i).Cells(13).Value & "_" & allRange.Rows(i).Cells(21).Value & "_" & "*.xlsx", 1)
        If coll.Count = 0 Then
            MsgBox "Не найдено ни одной цепочки с данными ИНН в папке" & vbNewLine & InvoiceFolder$, _
                vbExclamation, "Нет необработанных цепочек"
            Exit Sub
        End If
  
        For Each Filename In coll
            Set WB = Nothing: Set WB = Workbooks.Open(Filename, False, True)

            If WB Is Nothing Then    ' не удалось открыть файл
                Pi.Log vbTab & "ОШИБКА при загрузке файла. Файл не обработан."
            Else    ' файл успешно открыт
                Set sh = WB.Worksheets(1)    ' будем брать данные с первого листа
                ' берем диапазон ячеек с ячейки a1 до последней заполненной в столбце a
                Set ra = sh.Range(sh.Range("a1"), sh.Range("a" & sh.Rows.Count).End(xlUp))

                ' ==== переносим данные в наш файл (shb - кодовое имя листа, куда помещаем данные)
                ws2.Range("a1" & shb.Rows.Count).End (xlUp)
                Application.WorksheetFunction.Transpose (ra.Value)
                ' ==== конец обработки данных из очередного файла
            End If
        Next Filename
        
        SaveAsFile "Приложение № 2 к Регламенту" & ".xlsx", allRange.Rows(i).Cells(4).Value & "_" & allRange.Rows(i).Cells(13).Value & "_" & allRange.Rows(i).Cells(21).Value & "_" & i
    Next i
    
    MsgBox "Генерация файлов завершена"
End Sub
 
Выделяет все равно invoicefolder$ И пишет «can’t find project or library»
я вообще использую его для того, чтобы он определял папку поиска файлов ту в которой макрос и находится независимо от того в какую папку макрос закинуть
Эксель 2010й
Изменено: Артем Медведев - 27.07.2020 15:32:28
 
Вот функции:
читабельнее к сожалению не сделать, пишу с телефона...( сейчас на работе и макрос сейчас очень пригодился бы(((
Код
Function SaveAsFile(fileName As String, folderName As String)
Dim FSO As Scripting.FileSystemObject
Set FSO = New Scripting.FileSystemObject
Dim FolderPath As String
FolderPath = ThisWorkbook.Path & "\" & folderName
FolderPath = Replace(FolderPath, Chr(34), "")
If Not FSO.FolderExists(FolderPath) Then
    FSO.CreateFolder FolderPath
End If
Dim WB As Workbook
    Set WB = Workbooks.Add
    ThisWorkbook.Sheets("Приложение №2").Copy Before:=WB.Sheets(1)
    WB.SaveAs FolderPath & "\" & fileName
    WB.Close
    
End Function

Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 1) 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 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
Выделяет все равно invoicefolder$ И пишет «can’t find project or library»
я вообще использую его для того, чтобы он определял папку поиска файлов ту в которой макрос и находится независимо от того в какую папку макрос закинуть
Эксель 2010й
 
Ну, раз вы свой файл не выкладываете, то вот мой (там просто ваш код, без данных на листах).
Вы, кстати, подключили библиотеку Microsoft Scripting Runtime в меню Tools - References... ?

Откройте мой файл, перейдите на свою книгу и запустите макрос

P.S. Без ваших файлов как я могу потестировать что-то?
 
Не получилось... я подготовил Файлы для тестов, почему-то не срабатывает макрос, либо жалуется на отсутсвие library or project, либо после правки через одно сохранение начинает писать что не может найти путь к DLL , после макрос не работает и не даёт редактировать его, копировать и вообще что либо делать с ним...
Библиотеку подключил
в первый раз запуска выжал ошибку «run time error 9. Subscript out of range»
 
Вот так?

P.S. Что-то другие коллеги с форума не хотят вам помогать )
P.P.S. Что-то у меня такое ощущение, что код вам писал Игорь (EducatedFool)...
Изменено: New - 27.07.2020 20:44:08
 
Я не программист, не начинал с нуля как говорится, ранее занимался недолго html, а теперь в рабочих нуждах требуется такой макрос для автоматизации производственного процесса, долгого и нудного, представьте все что делает макрос приходилось делать вручную по 1000 и более позиций - создать файл, папки, и затем раскидывать их в правильном порядке, а потом переименовывать каждый копипастом. Далее дело дошло до оптимизации и появился макрос которым возможно создание папок и приходилось просто раскидывать файлы по папкам и переименовывать
и когда все это надоело, начал копаться и пытаться собрать макрос, за основу взял свой предыдущий, погуглил в инете и по функциям подошёл макрос Игоря , и пытался ночами свести со своим , чтобы работало😅 лень двигатель прогресса) зато буду тратить на 3-4 часа меньше и делать иные функции по работе
 
Ну, автоматизация и программирование это отлично. Руками многие задачи до пенсии можно делать. Мой код работает нормально?
Изменено: New - 27.07.2020 20:54:56
 
Выделяет ws1 после «set» и пишет compile error: can’t find project or library, боюсь с ws2 будет тоже самое... добавил перед этим «ws1 as worksheet, ws2 as worksheet, теперь выделяет с той же самой ошибкой «i» , но i это же счетоводная переменная обычно в программировании, она тоже нуждается в определении? Как ее тогда определить?
может это потому что у меня 2010й Эксель?
 
ну, я переменные не определял, оставил как было в вашем коде. У меня всё работает. Что-то с вашим Excel. Попробуйте старше версию (у меня 2019 стоит)
 
Спасибо большое! Увы старше версию не поставить, закрытое ПО :(
Попробую определить переменные, может у вас есть мысль как определить переменную i?😅
 
Ну. вы дома поставьте Excel поновее и потестируйте код.

Поймите, у вас ошибки возникают не из-за кода. А из-за какого-то глюка в Excel. Даже если вы все переменные объявите (можно просто взять файл из вложения), у вас всё равно будет на что-то ругаться.

Вот, определил все переменные в Module1
P.S. Для информации, как пример:
Код
Dim s As String - переменная будет строкой
Dim i As Long - переменная будет целым числом
Dim w As Workbook - переменная будет книгой Excel
Dim sht As Worksheet - переменная будет листом Excel.
Dim amount As Double - будет числом с плавающей дочкой (дробное)

То есть если переменная i будет номером строки, то это будет целое число, соответственно Dim i As Long должно быть.

Ещё есть директива Option Explicit - пишется вверху модуля, тогда все использованные переменные в этом Модуле должны быть явно объявлены, то есть переменным необходимо указать каким типом они будут. Я как раз эту директиву и указал сейчас вверху модуля. Если она вам будет мешать, то удалите эту строку (Option Explicit) из модуля
Изменено: New - 27.07.2020 21:53:10
 
Спасибо огромное! Действительно работает на домашнем компьютере, попробую завтра на рабочей станции
Получается Игорь достаточно известная персона?)
 
угу, я же говорил что такие ошибки типа can’t find project or library возникающие при несложных макросах - это глюк Excel.

P.S.  ну, вы посидите на форумах по Excel лет 10-15 (я на этом форуме года с 2008) и вы будете знать многих). Ваш код не был подписан, что он создан именно Игорем, но по стилю программирования я узнал Игоря. У каждого человека свой стиль программирования (объявления переменных, форматирования, комментариев, плюс свои однотипные заготовки в виде функций, классов и т.д.). А так да, Игорь известный человек в мире Excel... как и ещё человек 50
Изменено: New - 27.07.2020 22:54:59
 
New, Здравствуйте. И вот спустя 8 лет я тоже наткнулся на код Игоря)) И мне нужна помощь.
Код
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

Вопрос вот в чем. Дома на excel 2019 вроде все работает на ура.
На работе excel ругается что переменная FSO не объявлена. Как так?
 
Ну, некоторые программисты не объявляют переменные в коде макросов, т.е. vba позволяет это не делать.
Просто напишите Dim FSO второй строкой после названия макроса.
И так же на другие переменные, если будет ругаться.
Либо удалите эти 2 слова Option Explicit, которые у вас написаны в модуле в самом верху
Изменено: New - 19.10.2021 22:54:12
 
New, Спасибо. Попробую - отпишусь!)
 
Цитата
lemuriec:' Ïîëó÷àåò
чтобы таких "кракозябр" не было — при копировании убедитесь, что на клавиатуре выставлена кириллическая (русская) раскладка  ;)

Цитата
New: некоторые программисты не объявляют переменные в коде макросов, т.е. vba позволяет это не делать…удалите эти 2 слова Option Explicit
фу-фу-фу: плохому учить - нечитабельные коды плодить  :D
VARIABLE NOT DEFINED ИЛИ ЧТО ТАКОЕ OPTION EXPLICIT И ЗАЧЕМ ОНО НУЖНО?

Цитата
New: напишите Dim FSO
а ведь начал хорошо, только, если неохота (или нет возможности) библиотеку подключить (а именно это я бы и советовал сделать), то всё-таки Dim FSO As Object, хотя, безусловно, и вариативная сработает (она ведь универсальная), но понимания ТСом намного меньше будет

P.S.: у меня самого складывается впечатление, что я второй день подряд только тем и занимаюсь, что слежу за твоими постами и задалбливаю поправками  :sceptic:
Уверяю, это не так - просто так получается  :)
Изменено: Jack Famous - 20.10.2021 09:50:25
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Ничего страшного, пиши.
Я так понял человек использует чужие коды, а не свои, поэтому дал общий пример как обойти эту проблему. В VBA можно вообще ничего не объявлять и это несильно сказывается на работе кода. Это уже когда долго программируешь начинаешь следить за этим, а на начальном этапе это отвлекает и кажется сложным. Представь ты пришел в 1-й класс, а тебе сразу начертательную геометрию. Поэтому всё поэтапно должно быть.
Изменено: New - 20.10.2021 12:39:28
 
Если в первом классе (и в садике тоже) не учить буквы, как научиться позже правильно читать?
 
Если человек сам не пишет макросы на постоянной основе - ему нафиг не нужны никакие объявления переменных. Нашел код в интернете - скопировал себе в книгу - код делает то, что надо и отлично. Вон Игорь (EducatedFool) сколько лет уже пишет макросы на платной основе и вообще ничего не объявляет, БМВ ничего не объявляет и ничего, живут с этим нормально, пишут кучу макросов. Просто мне их коды сложно проверять-тестировать. Копирую к себе в модуль, запускаю и начинается .... Variable not defined... И начинаешь Dim'ы писать, хотя могу просто Opt.Explicit удалить. Каждый дроч... как хочет. VBA позволяет так делать
Изменено: New - 20.10.2021 12:54:43
 
Цитата
New: Представь ты пришел в 1-й класс, а тебе сразу начертательную геометрию. Поэтому всё поэтапно должно быть
некорректный пример
Тут строго наоборот - ты умеешь писать "корова" и "собака", но кто из них даёт молоко, а кто за жопу может цапнуть — не в курсе  ;)

Тут как и с любой наукой (или музыкальными инструментами) — лучше сразу учиться, "как правильно", чтобы потом не было болезненно больно на каждом этапе
К тому же при правильном объявлении и куча подсказок по методам будет от IntelliSense  :idea:

Цитата
New: Игорь ничего не объявляет, БМВ…
они хотя бы знают, что к чему
То, что человек делает коммерческие решения вообще никак не связано с его профессионализмом в VBA (я пытаюсь судить Игоря, а в целом) - можно быть успешным фрилансером и не использовать массивы, словари и прочие ништяки, а всегда делать кучу циклов. Будет медленно, но работать-то будет. Какие проблемы  :D

Коды обоих я всегда его переписываю так или иначе, если использую (и это абсолютно нормально)
Медведь ленится + считает (и я с ним согласен), что ТС хоть что-то должен сам сделать - например, объявить переменные

Вот кого реально очень редко можно дополнить или как-то поправить, так это Дмитрий(The_Prist) Щербаков (автор статьи по моей ссылке в #24)
У него очень строгий алгоритмический подход не только к объявлению, но и к именам всех переменных
Кстати, тоже имеет и свой сайт, и платную надстройку  ;)

Цитата
New: VBA позволяет так делать
ну как бы да, и в суд никто не подаст, и по скорости при прочих равных может быть тоже самое, однако лично для меня - это определённый показатель "лица" программиста, и, как я уже успел убедиться, в нескольких крупных компаниях того же мнения
Изменено: Jack Famous - 20.10.2021 13:13:13
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
)) ну, тут все останутся при своём мнении)
 
New, не в первый раз  :D
Доброго дня  ;)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Страницы: 1
Наверх