Помогите добавить в код относительную ссылку на папку с файлами

[evgenw]

Добрый день, в VBA очень слаб, в просторах интернета нашел код и приспособил для своих нужд. Он из папки в которой файл "Сбор данных" перебирает все другие фалы, копирует и вставляет все данные из них в "Сбор данных". Хотелось бы сделать в этой папке папку "Заявки" и что-б он брал перебирал файлы только в ней, желательно относительной ссылкой.

Sub ОчисткаСводнойТаблицы()
    Application.ScreenUpdating = False
    Me.Range("2:5000").ClearContents
    Me.Range("2:500").EntireRow.AutoFit
End Sub

Sub ЗаполнениеСводнойТаблицы()
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    
    Dim coll As New Collection, wb As Workbook, sh As Worksheet, newRow As Range
    Mask = Replace(ThisWorkbook.FullName, ThisWorkbook.name, "*.xls")
    
    Filename = Dir(Mask)
    While Filename <> ""    ' перебираем все файлы в текущей папке
        If Not Filename Like ThisWorkbook.name & "*" Then coll.Add Filename
        Filename = Dir
    Wend

    On Error Resume Next
    For Each Item In coll
        Set wb = Workbooks.Open(Replace(ThisWorkbook.FullName, ThisWorkbook.name, Item), , True)
        If Not wb Is Nothing Then
            Set sh = wb.Worksheets(1)
            LastRow = sh.Range("a65000").End(xlUp).Row
            If LastRow > 2 Then    ' если есть заполненные строки
                For i = 3 To LastRow
                    Set newRow = Me.Range("a65000").End(xlUp).Offset(1)
                    sh.Rows(i).Copy newRow
                    newRow.EntireRow.AutoFit
                    ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
                    Next i
                     
                   
            End If
          wb.Close False
        End If
    Next
    Application.DisplayAlerts = True

End Sub

Спасибо

_____
Код программы нужно выделять (форматировать) тегами [CODE] (читать FAQ)
Модератор

[IgorGO]

вместо

Mask = Replace(ThisWorkbook.FullName, ThisWorkbook.name, "*.xls")

пишите:

ps = application.pathseparator
Mask = ThisWorkbook.path & ps & "Заявки" & ps & "*.xls")

предполагается, что папка Заявки находится в той же папке, в которой файл с рассматриваемым макросом

[evgenw]

Сообщение от IgorGO

вместо

Mask = Replace(ThisWorkbook.FullName, ThisWorkbook.name, "*.xls")

пишите:

ps = application.pathseparator
Mask = ThisWorkbook.path & ps & "Заявки" & ps & "*.xls")

предполагается, что папка Заявки находится в той же папке, в которой файл с рассматриваемым макросом

Что то не получается

ps = application.pathseparator
Mask = ThisWorkbook.path & ps & "Заявки" & ps & "*.xls")

Может быть дело в одной "Закрытой" скобке? Перепробовал несколько вариантов и со скобками и без все равно не работает

[IgorGO]

да, извините, закрывающаяся скобка - это опечатка там. удалите ее ( а совсем без скобок пробовали?)))

[evgenw]

Сообщение от IgorGO

да, извините, закрывающаяся скобка - это опечатка там. удалите ее ( а совсем без скобок пробовали?)))

Да, он тогда берет информацию с 1 файла который находится вместе с "Сбором данных" и на этом все заканчивается

[IgorGO]

предполагается, что папка Заявки находится в той же папке, в которой файл с рассматриваемым макросом

это мои предположения, а где находятся Ваши файлы МНЕ НЕ ИЗВЕСТНО!
нет вопроса - нет ответа. есть только предположения

[evgenw]

Хотелось бы сделать в этой папке папку "Заявки"

Да, да все верно в одной папке находидтся файл "Сбор данных" и папка "Заявки" в которой аккумулируются файлы из которых нужно вытащить информацию.

Может нужно указывать "\..\Заявки\" или как то так?

[IgorGO]

нет вопроса - нет ответа

очевидно, что Вы никому ничего не обязаны обьяснить
так же как и очевидно, что никто Вам не поможет не понимая, что нужно сделать и в каких условиях.

[evgenw]

Сообщение от IgorGO

очевидно, что Вы никому ничего не обязаны обьяснить
так же как и очевидно, что никто Вам не поможет не понимая, что нужно сделать и в каких условиях.

Нужно сделать: Есть код задача которого собрать из всех файлов находящихся в папке с ним же, кроме самого себя, информацию и скопировать-вставить эту информацию в "Свой файл" назовем его условно "Сбор данных"

Sub ЗаполнениеСводнойТаблицы()
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
        
    Dim coll As New Collection, wb As Workbook, sh As Worksheet, newRow As Range
    Mask = Replace(ThisWorkbook.FullName, ThisWorkbook.name, "*.xls")
    
    
    Filename = Dir(Mask)
    While Filename <> ""    ' перебираем все файлы в текущей папке
        If Not Filename Like ThisWorkbook.name & "*" Then coll.Add Filename
        Filename = Dir
    Wend

    On Error Resume Next
    For Each Item In coll
        Set wb = Workbooks.Open(Replace(ThisWorkbook.FullName, ThisWorkbook.name, Item), , True)
        If Not wb Is Nothing Then
            Set sh = wb.Worksheets(1)
            LastRow = sh.Range("a65000").End(xlUp).Row
            ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
            If LastRow > 2 Then    ' если есть заполненные строки
                For i = 3 To LastRow
                    Set newRow = Me.Range("a65000").End(xlUp).Offset(1)
                    sh.Rows(i).Copy newRow
                    newRow.EntireRow.AutoFit
                    Next i
                     
                   
            End If
          wb.Close False
        End If
    Next
    Application.DisplayAlerts = True
    

End Sub

Вопрос: Как сделать так чтоб "Код" перебирал файлы не в папке с ним же, а чуть глубже, например папке "Заявки". Файл "Сбор данных" и папка "Заявки" находятся в одной папке.
П.С. Потому что в дальнейшем файл "Сбор данных" будет дублироваться и сохранятся с другим именем и при "следующих обновлениях" "Сбор данных" будет собирать информацию не только с заявок, а и из своих копий поэтому их желательно держать в разных местах.
П.С.С В принципе можно "Сбор данных" вынести в отдельную папку, а заявки пусть остаются в "Корне" или и то и другое по разным папкам...

Может скрины сделать?

[IgorGO]

Sub ЗаполнениеСводнойТаблицы()
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
        
    Dim coll As New Collection, wb As Workbook, sh As Worksheet, newRow As Range

    ps = application.pathseparator
    Mask = ThisWorkbook.path & ps & "Заявки" & ps & "*.xls"

    Filename = Dir(Mask):   msgbox filename
...