Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Объединить файлы с определенной частью названия файла
 
Всем привет
Был макрос, который объединял все файлы.
Был макрос, который перебирал папки

А как сделать, чтобы макрос искал файлы с определенной маской и объединял их (например маска файла -магазин)
то есть берется файл, ищется во всех папках по маске и объединяется, если маска совпадает

Никак не могу как это сделать

Код
  Const FRow& = 5                ' Номер строки начала сбора данных (ниже шапки)
  Const Sborka$ = "Сборка.xls"   ' Имя сборочного файла
    Dim FCol&, LCol&               ' Переменные номеров первого и последнего столбца для сбора данных
    Dim LRow&, LRow_Cel&
    Dim wb_Cel As Workbook, wb_Tek As Workbook
    Dim Sh_Cel As Worksheet, Sh_Tek As Worksheet
    Dim MyPath$, MyFileName$, MyFulName$
    Dim Uslovie1 As Boolean
    

 '     Выбор папки
 With Application.FileDialog(msoFileDialogFolderPicker)
       .Title = "Укажите рабочую папку": .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        MyPath = .SelectedItems(1) & "\"
    End With
        

          

Set myobject = CreateObject("Scripting.FileSystemObject")
Set mysource = myobject.GetFolder(MyPath)


For Each mySubFolder In mysource.SubFolders
    Set mysource = myobject.GetFolder(mySubFolder.Path)
    For Each MyFile In mysource.Files

    MyFileName = Dir(mysource & "\*.xls*")
    ''' Do Something with files in sub folders





    Uslovie1 = False
    Do Until MyFileName = ""

        If MyFileName <> ThisWorkbook.Name Then
            MyFulName = mysource & "\" & MyFileName
            Workbooks.Open Filename:=MyFulName, UpdateLinks:=0
            
            
            If Not Uslovie1 Then
                Set wb_Cel = ActiveWorkbook
               Application.DisplayAlerts = False
                ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & Sborka, FileFormat:=xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
                Uslovie1 = True
            Else
                Set wb_Tek = ActiveWorkbook
                For Each Sh_Cel In wb_Cel.Sheets
                    With Sh_Cel
                        FCol = .UsedRange.Cells(1, 1).Column
                        LCol = .UsedRange.Columns.Count + FCol - 1
                        LRow_Cel = .Cells(.Rows.Count, FCol).End(xlUp).Row + 1
                    End With
                    For Each Sh_Tek In wb_Tek.Sheets
                        If Sh_Tek.Name = Sh_Cel.Name Then
                            With Sh_Tek
                                LRow = .Cells(.Rows.Count, FCol).End(xlUp).Row
                                If LRow >= FRow Then
                                    .Range(.Cells(FRow, FCol), .Cells(LRow, LCol)).Copy Sh_Cel.Cells(LRow_Cel, 1)
                                End If
                            End With
                            With Sh_Cel
                                    Range(.Cells(LRow_Cel, 2 + LCol - FCol), .Cells(LRow_Cel + LRow - FRow, 2 + LCol - FCol)) = MyFulName
                            End With
                        End If
                    Next Sh_Tek
                Next Sh_Cel
                Workbooks(MyFileName).Close SaveChanges:=False
            End If
        End If
        MyFileName = Dir
    Loop







    Next
Next
 
а "во всех папках" - это не слишком?
может есть смысл конкретизировать, начиная с какой?
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
Ігор Гончаренко написал:
а "во всех папках" - это не слишком?может есть смысл конкретизировать, начиная с какой?
8 папок, которые находятся в MyPath
 
Jenya1980,
Код
Like
не пробовали использовать? Создайте условие и если имя файла содержит указанную Вами маску, то обрабатывать, иначе переходить к следующему файлу.
Изменено: Nordheim - 12 Фев 2019 14:52:15
"Все гениальное просто, а все простое гениально!!!"
 
Код
Function WildFilter(SourceArray() As String, ByVal Match As String) As String()
 
    Dim astrSelected() As String
    Dim i&, j&
 
    For i = LBound(SourceArray) To UBound(SourceArray)
        If SourceArray(i) Like Match Then
            ReDim Preserve astrSelected(0 To j)
            astrSelected(j) = SourceArray(i)
            j = j + 1
        End If
    Next

    WildFilter = astrSelected
End Function
Как сделать? Фильтруйте их.
В VBA есть штатная функция Filter(), но она не работает с маской. Видоизмененная выше - работает.
Match - ваша маска для фильтрации массива файлов. Например: "*магазин*"
Изменено: eeigor - 12 Фев 2019 15:36:47
 
Цитата
eeigor написал:
В VBA есть штатная функция Filter(), но она не работает с маской
В данном случае как раз
Код
?join(filter(array("магазин одежды","гастроном","фирменный магазин"),"МАГАЗИН",,vbTextCompare),",")
магазин одежды,фирменный магазин
Изменено: Казанский - 12 Фев 2019 16:44:11
 
Да. Думал иначе. Было не очевидно, что это не вся строка для поиска, а подстрока (строка в строке).
Тогда Filter() упрощает фильтрацию: никаких Like и не надо.
Но этот вариант тоже найдет:
фирменный магазинчик
Изменено: eeigor - 12 Фев 2019 17:09:14
 
Спасибо огромное!!!

а в каком месте макроса нужно вызывать функцию?
Изменено: Jenya1980 - 13 Фев 2019 14:41:42
Страницы: 1
Читают тему (гостей: 1)
Наверх