Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 11.10.2016, 14:45   #1
evgenw
 
Регистрация: 17.07.2016
Сообщений: 9
По умолчанию Помогите добавить в код относительную ссылку на папку с файлами

Добрый день, в 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)
Модератор

Последний раз редактировалось Serge_Bliznykov; 11.10.2016 в 14:58.
evgenw вне форума Ответить с цитированием
Старый 11.10.2016, 14:54   #2
IgorGO
Новичок
СтарожилДжуниор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Сообщений: 9,487
По умолчанию

вместо
Код:
Mask = Replace(ThisWorkbook.FullName, ThisWorkbook.name, "*.xls")
пишите:
Код:
ps = application.pathseparator
Mask = ThisWorkbook.path & ps & "Заявки" & ps & "*.xls")
предполагается, что папка Заявки находится в той же папке, в которой файл с рассматриваемым макросом
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете
IgorGO вне форума Ответить с цитированием
Старый 11.10.2016, 16:38   #3
evgenw
 
Регистрация: 17.07.2016
Сообщений: 9
По умолчанию

Цитата:
Сообщение от 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")
Может быть дело в одной "Закрытой" скобке? Перепробовал несколько вариантов и со скобками и без все равно не работает
evgenw вне форума Ответить с цитированием
Старый 11.10.2016, 16:51   #4
IgorGO
Новичок
СтарожилДжуниор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Сообщений: 9,487
По умолчанию

да, извините, закрывающаяся скобка - это опечатка там. удалите ее ( а совсем без скобок пробовали?)))
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете
IgorGO вне форума Ответить с цитированием
Старый 11.10.2016, 17:07   #5
evgenw
 
Регистрация: 17.07.2016
Сообщений: 9
По умолчанию

Цитата:
Сообщение от IgorGO Посмотреть сообщение
да, извините, закрывающаяся скобка - это опечатка там. удалите ее ( а совсем без скобок пробовали?)))
Да, он тогда берет информацию с 1 файла который находится вместе с "Сбором данных" и на этом все заканчивается
evgenw вне форума Ответить с цитированием
Старый 11.10.2016, 17:11   #6
IgorGO
Новичок
СтарожилДжуниор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Сообщений: 9,487
По умолчанию

Цитата:
предполагается, что папка Заявки находится в той же папке, в которой файл с рассматриваемым макросом
это мои предположения, а где находятся Ваши файлы МНЕ НЕ ИЗВЕСТНО!
нет вопроса - нет ответа. есть только предположения
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете
IgorGO вне форума Ответить с цитированием
Старый 11.10.2016, 17:23   #7
evgenw
 
Регистрация: 17.07.2016
Сообщений: 9
По умолчанию

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

Может нужно указывать "\..\Заявки\" или как то так?
evgenw вне форума Ответить с цитированием
Старый 11.10.2016, 17:30   #8
IgorGO
Новичок
СтарожилДжуниор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Сообщений: 9,487
По умолчанию

Цитата:
нет вопроса - нет ответа
очевидно, что Вы никому ничего не обязаны обьяснить
так же как и очевидно, что никто Вам не поможет не понимая, что нужно сделать и в каких условиях.
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете
IgorGO вне форума Ответить с цитированием
Старый 11.10.2016, 17:47   #9
evgenw
 
Регистрация: 17.07.2016
Сообщений: 9
По умолчанию

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

Может скрины сделать?
evgenw вне форума Ответить с цитированием
Старый 11.10.2016, 19:15   #10
IgorGO
Новичок
СтарожилДжуниор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Сообщений: 9,487
По умолчанию

Код:
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
...
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете

Последний раз редактировалось IgorGO; 11.10.2016 в 19:27.
IgorGO вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
помогите чайнику-как вставить ссылку ссылку на партнерскую программу nony Помощь студентам 1 19.03.2014 20:48
Как добавить папку в solution? Pti44ka Общие вопросы .NET 1 10.06.2010 10:16
Как настроить ссылку указав только папку? juan666777 HTML и CSS 2 29.01.2010 12:57
Как открыть папку,нажимая на ссылку в HTML-документе? Zap PHP 3 20.05.2009 00:19
Отправить по e-mail папку с файлами Titan123 Работа с сетью в Delphi 4 22.12.2008 19:42