Поправьте код!!!

[ascer]

Вот здесь вылетает ошибка

shSrc.Range(Cells(6, 1), Cells(lastrow, 10)).Copy clTarget 'копирование диапазона от А6 и до конца в новый файл

Run-time Error 1004
Method 'Range' of object '_Worksheet' failed

[pivas]

Не надо проверять, есть ли в данной книге лист с именем "Лист1" (If shSrc.Name <> "Лист1"). Обращайтесь сразу к листу, который стоит первым по порядку в ниге (Sheets(1)).

[ascer]

Изменил код

For i = 1 To UBound(arFiles)
    .StatusBar = "Обработка файла " & i & " из " & UBound(arFiles)
    Set wbSrc = Workbooks.Open(arFiles(i), ReadOnly:=True)
    
    lastrow = wbSrc.Sheets(1).Cells.SpecialCells(xlLastCell).Row  'определение номера последней строки
    wbSrc.Sheets(1).Range(Cells(6, 1), Cells(lastrow, 10)).Copy clTarget 'копирование диапазона от А6 и до конца в новый файл

    wbSrc.Close False   'закрыть без запроса на сохранение
Next

Проблема осталась, Ошибка та же. Причем lastrow отлично вычисляется, что означает, что обрабатывается именно лист1, но следующая строка

wbSrc.Sheets(1).Range(Cells(6, 1), Cells(lastrow, 10)).Copy clTarget 'копирование диапазона от А6 и до конца в новый файл

дает ошибку

[SAS888]

При обращении к ячейке неактивного листа, требуется обязательная ссылка на этот лист. У Вас в строке

wbSrc.Sheets(1).Range(Cells(6, 1), Cells(lastrow, 10)).Copy clTarget

получается обращение к диапазону одного листа (wbSrc.Sheets(1).Range...), а границы диапазона заданы на другом (активном) листе (Cells(6, 1), Cells(lastrow, 10)).
Правильно так:

With wbSrc.Sheets(1)
    .Range(.Cells(6, 1), .Cells(lastrow, 10)).Copy clTarget
End With

[ascer]

если записать так, то ошибка сразу выскакивает, даже на нормальных файлах

[ascer]

Спасибо, SAS888 за подсказку, действительно надо было активировать лист, чтобы пользоваться Range + Cells.

Также спасибо pivas, правда Вашим советом не смог воспользоваться, пришлось вернуться к проверке. Зато теперь код работает, хотя конечно неоптимально я его модифицировал.

Sub FiziK()
 
Const strStartDir = "c:\test" 'папка, с которой начать обзор файлов
Const strSaveDir = "c:\test\result" 'папка, в которую будет предложено сохранить результат
Const blInsertNames = False  'вставлять строку заголовка (книга, лист) перед содержимым листа
 
Dim wbTarget As New Workbook, wbSrc As Workbook, shSrc As Worksheet, shTarget As Worksheet, arFiles, _
    i As Integer, stbar As Boolean, clTarget As Range
 
On Error Resume Next    'если указанный путь не существует, обзор начнется с пути по умолчанию
ChDir strStartDir
On Error GoTo 0
With Application    'меньше писанины
arFiles = .GetOpenFilename("Excel Files (*.xls), *.xls", , "Объединить файлы", , True)
If Not IsArray(arFiles) Then End 'если не выбрано ни одного файла
Set wbTarget = Workbooks.Add(template:=xlWorksheet)
Set shTarget = wbTarget.Sheets(1)
    .ScreenUpdating = False
    stbar = .DisplayStatusBar
    .DisplayStatusBar = True
 
For i = 1 To UBound(arFiles)
    .StatusBar = "Обработка файла " & i & " из " & UBound(arFiles)
    Set wbSrc = Workbooks.Open(arFiles(i), ReadOnly:=True)
    
     For Each shSrc In wbSrc.Worksheets
      If shSrc.Name <> "Лист1" Then GoTo 30 ' выбор первого листа
        If IsNull(shSrc.UsedRange.Text) Then 'лист не пустой
            Set clTarget = shTarget.Range("A1").Offset(shTarget.Range("A1").SpecialCells(xlCellTypeLastCell).Row, 0)
            If blInsertNames Then
                clTarget = ">>> " & wbSrc.Name & " -- " & shSrc.Name
                Set clTarget = clTarget.Offset(1, 0)
            End If
            lastrow = shSrc.Cells.SpecialCells(xlLastCell).Row  'определение номера последней строки
            shSrc.Activate
            shSrc.Range(Cells(6, 1), Cells(lastrow, 10)).Copy clTarget 'копирование диапазона от А6 и до конца в новый файл
        End If
30:
     Next

    wbSrc.Close False   'закрыть без запроса на сохранение
Next
    .ScreenUpdating = True
    .DisplayStatusBar = stbar
    .StatusBar = False
 
On Error Resume Next    'если указанный путь не существует и его не удается создать,
                        'обзор начнется с последней использованной папки
If Dir(strSaveDir, vbDirectory) = Empty Then MkDir strSaveDir
ChDir strSaveDir
On Error GoTo 0
arFiles = .GetSaveAsFilename("Результат", "Excel Files (*.xls), *.xls", , "Сохранить объединенную книгу")
 
If VarType(arFiles) = vbBoolean Then 'если не выбрано имя
    GoTo save_err
Else
    On Error GoTo save_err
    wbTarget.SaveAs arFiles
End If
End
save_err:
    MsgBox "Книга не сохранена!", vbCritical
End With
End Sub