Сбор данных только первых листов разных книг

[Dilmira]

Есть код объединения файлов. Как его можно подправить чтобы собирать только первые листы всех файлов.

Sub Дистрибьюция()

Const strStartDir = "Z:\Новая папка" 'папка, с которой начать обзор файлов
Const strSaveDir = "Z:\Новая папка\result" 'папка, в которую будет предложено сохранить результат

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 IsNull(shSrc.UsedRange.Text) Then 'лист не пустой
Set clTarget = shTarget.Range("A1").Offset(shTarge t.Range("A1").SpecialCells(xlCellTy peLastCell).Row, 0)
If blInsertNames Then
clTarget = ">>> " & wbSrc.Name & " -- " & shSrc.Name
Set clTarget = clTarget.Offset(1, 0)
End If
shSrc.UsedRange.Copy clTarget
End If
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

[SAS888]

Не вникал в код, но, по-моему, достаточно после строки

Set wbSrc = Workbooks.Open(arFiles(i), ReadOnly:=True)

добавить строку

Sheets(1).Activate

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

[Dilmira]

Что-то несрабатывает также продолжает собирать все листы.

[EducatedFool]

        For i = 1 To UBound(arFiles)
            .StatusBar = "Обработка файла " & i & " из " & UBound(arFiles)
            Set wbSrc = Workbooks.Open(arFiles(i), ReadOnly:=True)
            
            Set shSrc = wbSrc.Worksheets(1)
            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
                shSrc.UsedRange.Copy clTarget
            End If

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

[Dilmira]

Все отлично работает. СПАСИБО!!!

[Dilmira]

Задача усложнилась. Теперь нужно собрать не просто первые листы, а только определенные данные с первого листа.
Есть несколько перечней номеров. Каждый номер имеет определенный складской код. Необхоимо собрать перечни по складским кодам.

[EducatedFool]

Задача усложнилась

сочувствуем

Теперь нужно собрать не просто первые листы, а только определенные данные с первого листа.

Кому нужно? вам? или нам?

В чем ваш вопрос?
Или просто решили горем поделиться? )