Форум программистов
 
Контакты: о проблемах с регистрацией, почтой и по другим вопросам пишите сюда - alarforum@yandex.ru, проверяйте папку спам! Обязательно пройдите активизацию e-mail.

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

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

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

Добрый день, в 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 в 15:58.
evgenw вне форума   Ответить с цитированием
Старый 11.10.2016, 15:54   #2
IgorGO
МегаМодератор
СуперМодератор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Адрес: УКРАЇНА, Київ
Сообщений: 9,084
Репутация: 1731

icq: 7934250
skype: i2x0,5
По умолчанию

вместо
Код:

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

пишите:
Код:

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

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

Цитата:
Сообщение от 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, 17:51   #4
IgorGO
МегаМодератор
СуперМодератор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Адрес: УКРАЇНА, Київ
Сообщений: 9,084
Репутация: 1731

icq: 7934250
skype: i2x0,5
По умолчанию

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

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

icq: 7934250
skype: i2x0,5
По умолчанию

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

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

Может нужно указывать "\..\Заявки\" или как то так?
evgenw вне форума   Ответить с цитированием
Старый 11.10.2016, 18:30   #8
IgorGO
МегаМодератор
СуперМодератор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Адрес: УКРАЇНА, Київ
Сообщений: 9,084
Репутация: 1731

icq: 7934250
skype: i2x0,5
По умолчанию

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

Цитата:
Сообщение от 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, 20:15   #10
IgorGO
МегаМодератор
СуперМодератор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Адрес: УКРАЇНА, Київ
Сообщений: 9,084
Репутация: 1731

icq: 7934250
skype: i2x0,5
По умолчанию

Код:

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
...

__________________
41001804815208 - Яндекс-деньги благодарности за удачные советы и решения можно отправлять прямо сюда)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете

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

Опции темы

Ваши права в разделе
Вы не можете создавать новые темы
Вы не можете отвечать в темах
Вы не можете прикреплять вложения
Вы не можете редактировать свои сообщения

BB коды Вкл.
Смайлы Вкл.
[IMG] код Вкл.
HTML код Выкл.

Быстрый переход

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


10:23.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.

RusProfile.ru


Справочник российских юридических лиц и организаций.
Проекты отопления, пеллетные котлы, бойлеры, радиаторы
интернет магазин respective.ru