Помогите подправить макрос на сбор данных из разных файлов что-б вставлял значения

[evgenw]

Добрый день
Вот нашел старую тему где макросом собирают данные из разных файлов екселя и собирают в один
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

Спасибо

[SAS888]

Для того, чтобы удалить все ссылки и формулы, добавьте самой последней строкой

ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value

[evgenw]

Ага круто, вставил, только если в конце то, похоже, оно вставляет "ошибки", а потом их переводит в значения.
Я попробовал поместить чуть выше в тело функции

 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

Получилось только думать стало долго. Ускорить никак низя?

[SAS888]

Можно.
Зачем в цикле каждый раз заменять формулы на значения во всем используемом диапазоне рабочего листа, если достаточно это сделать только для текущего вставленного диапазона ячеек.
Для этого, после строки кода

newRow.EntireRow.AutoFit

используйте

With Intersect(newRow, [A:AX]): .Value = .Value: End With

[IgorGO]

можно.

вытащите это

ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value

перед циклом и оно выполниться 1 раз а не при копировании каждой строки

и обратите внимание: Вы в исходном файле УБЬЕТЕ ВСЕ ФОРМУЛЫ, он станет непригодным для повторного использования в случае внесения изменений в данные (формулы уже ничего не пересчитают, их нет)

[Hugo121]

Сообщение от 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

Так что в данном случае можно смело сразу после открытия файла заменять все формулы на значения.

[SAS888]

Можно упростить. Выбросить цикл по строкам и добавить удаление структур и проверки данных:

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

Пример во вложении.

[evgenw]

Ребята вы супер, Спасибище! Сори что поздно ответил внезапно другой работой завалили, только вернулся к этому. Все получилось и работает

[evgenw]

Ой, а еще момент если у меня стоит защита в какой нибуть книге с исходными данными то все-равно вставляются формулы, если защиту убрать то все ок. Можно это как то обойти ибо хотелось бы защитить нужные формулы от нерадивых пользователей. Немного по экспериментировал и решил оставить

 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

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