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

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

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

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

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

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

Добрый день
Вот нашел старую тему где макросом собирают данные из разных файлов екселя и собирают в один
http://www.programmersforum.ru/showthread.php?t=39712
Все круто но когда он переносит формулы они уже ссылаются на другие ячейки и получается не совсем то. Как можно сделать чтоб вставляло только значения?

Цитата:
Код:
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 > 4 Then    ' если есть заполненные строки
                For i = 5 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
Спасибо
Вложения
Тип файла: zip Заявки.zip (98.3 Кб, 18 просмотров)

Последний раз редактировалось evgenw; 01.08.2016 в 22:20. Причина: Добавил файлик
evgenw вне форума Ответить с цитированием
Старый 02.08.2016, 04:43   #2
SAS888
Старожил
 
Аватар для SAS888
 
Регистрация: 05.12.2007
Сообщений: 4,180
По умолчанию

Для того, чтобы удалить все ссылки и формулы, добавьте самой последней строкой
Код:
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
Чем шире угол зрения, тем он тупее.
SAS888 вне форума Ответить с цитированием
Старый 02.08.2016, 11:53   #3
evgenw
 
Регистрация: 17.07.2016
Сообщений: 9
По умолчанию

Ага круто, вставил, только если в конце то, похоже, оно вставляет "ошибки", а потом их переводит в значения.
Я попробовал поместить чуть выше в тело функции
Код:
 For i = 5 To LastRow
                    Set newRow = Me.Range("a65000").End(xlUp).Offset(1)
                    sh.Rows(i).Copy newRow
                    newRow.EntireRow.AutoFit
veSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
Получилось только думать стало долго. Ускорить никак низя?
evgenw вне форума Ответить с цитированием
Старый 02.08.2016, 12:04   #4
SAS888
Старожил
 
Аватар для SAS888
 
Регистрация: 05.12.2007
Сообщений: 4,180
По умолчанию

Можно.
Зачем в цикле каждый раз заменять формулы на значения во всем используемом диапазоне рабочего листа, если достаточно это сделать только для текущего вставленного диапазона ячеек.
Для этого, после строки кода
Код:
newRow.EntireRow.AutoFit
используйте
Код:
With Intersect(newRow, [A:AX]): .Value = .Value: End With
Чем шире угол зрения, тем он тупее.
SAS888 вне форума Ответить с цитированием
Старый 02.08.2016, 12:08   #5
IgorGO
Новичок
СтарожилДжуниор
 
Аватар для IgorGO
 
Регистрация: 05.02.2008
Сообщений: 9,487
По умолчанию

можно.

вытащите это
Код:
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
перед циклом и оно выполниться 1 раз а не при копировании каждой строки

и обратите внимание: Вы в исходном файле УБЬЕТЕ ВСЕ ФОРМУЛЫ, он станет непригодным для повторного использования в случае внесения изменений в данные (формулы уже ничего не пересчитают, их нет)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете
IgorGO вне форума Ответить с цитированием
Старый 02.08.2016, 23:30   #6
Hugo121
Старожил
 
Регистрация: 11.05.2010
Сообщений: 5,166
По умолчанию

Цитата:
Сообщение от IgorGO Посмотреть сообщение
можно.

вытащите это
Код:
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
перед циклом и оно выполниться 1 раз а не при копировании каждой строки

и обратите внимание: Вы в исходном файле УБЬЕТЕ ВСЕ ФОРМУЛЫ, он станет непригодным для повторного использования в случае внесения изменений в данные (формулы уже ничего не пересчитают, их нет)
Но это ведь на работу файла не повлияет - т.к. код действует так:
Код:
       Set wb = Workbooks.Open(Replace(ThisWorkbook.FullName, ThisWorkbook.Name, Item), , True)
        If Not wb Is Nothing Then
...
            wb.Close False
        End If
Так что в данном случае можно смело сразу после открытия файла заменять все формулы на значения.
webmoney: E265281470651 Z422237915069 R418926282008
Hugo121 вне форума Ответить с цитированием
Старый 03.08.2016, 08:18   #7
SAS888
Старожил
 
Аватар для SAS888
 
Регистрация: 05.12.2007
Сообщений: 4,180
По умолчанию

Можно упростить. Выбросить цикл по строкам и добавить удаление структур и проверки данных:
Код:
Sub ОчисткаСводнойТаблицы()
    Rows("2:" & Rows.Count).Delete
End Sub

Sub ЗаполнениеСводнойТаблицы()
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    Dim p As String, f As String, wb As Workbook, sh As Worksheet, LastRow As Long
    p = ThisWorkbook.Path & "\": f = Dir(p & "*.xls*")
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(p & f): Set sh = Sheets(1)
            ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
            LastRow = sh.[A65536].End(xlUp).Row
            If LastRow > 9 Then sh.Rows("10:" & LastRow).Copy Me.[A65536].End(xlUp).Offset(1)
            wb.Close False
        End If
        f = Dir
    Loop
    Cells.Validation.Delete: Cells.ClearOutline
End Sub
Пример во вложении.
Вложения
Тип файла: rar Свод.rar (17.7 Кб, 25 просмотров)
Чем шире угол зрения, тем он тупее.

Последний раз редактировалось SAS888; 03.08.2016 в 08:34.
SAS888 вне форума Ответить с цитированием
Старый 22.09.2016, 18:31   #8
evgenw
 
Регистрация: 17.07.2016
Сообщений: 9
По умолчанию

Ребята вы супер, Спасибище! Сори что поздно ответил внезапно другой работой завалили, только вернулся к этому. Все получилось и работает
evgenw вне форума Ответить с цитированием
Старый 22.09.2016, 18:56   #9
evgenw
 
Регистрация: 17.07.2016
Сообщений: 9
По умолчанию

Ой, а еще момент если у меня стоит защита в какой нибуть книге с исходными данными то все-равно вставляются формулы, если защиту убрать то все ок. Можно это как то обойти ибо хотелось бы защитить нужные формулы от нерадивых пользователей. Немного по экспериментировал и решил оставить
Код:
 For i = 5 To LastRow
                    Set newRow = Me.Range("a65000").End(xlUp).Offset(1)
                    sh.Rows(i).Copy newRow
                    newRow.EntireRow.AutoFit
veSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
хоть и долговато но стабильно и предсказуемо работает и в исходном файле, почему то, формулы остаются. Все как нужно.
evgenw вне форума Ответить с цитированием
Ответ


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

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

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Сбор данных с разных листов на один Сталкер18 Microsoft Office Excel 3 14.05.2015 10:24
сбор данных с разных книг в одну Ledy1987 Microsoft Office Excel 26 20.04.2011 21:33
Сбор данных из разных книг 804040 Microsoft Office Excel 2 19.04.2010 15:33
Сбор данных с разных файлов Fess111 Microsoft Office Excel 2 09.03.2010 10:13
Помогите плиз правильно написать макрос обновления данных из разных файлов Legame Microsoft Office Excel 10 10.09.2009 10:39