Приветствую "жителей Планеты"!
Прошу помочь со старым макросом, который любезно предоставили здесь в 2009 году.
Макрос собирает на один лист данные из разных файлов. Работает замечательно уже несколько лет.
Устраивает всё!
Но необходимо собирать данные с листов, кроме первой строки, в которой помещена "шапка", поскольку иначе в массив данных попадают и все шапки всех файлов, из которых массив собран.
Таким образом, нужно чтобы все данные копировались начиная со второй строки, а первую строку не затрагивали. Причём мне очень нужно в этом макросе иметь возможность изменять (по необходимости) номер строки, с которой начинается сбор данных.
Вот текст макроса:
Sub Консолидировать_данные()
Const strStartDir = "c:\Управленческий анализ\Импорт\" 'папка, с которой начать обзор файлов
Const strSaveDir = "c:\Управленческий анализ\Экспорт\" 'папка, в которую будет предложено сохранить результат
Dim wbTarget As New Workbook, wbSrc As Workbook, shSrc As Worksheet, shTarget As Worksheet, arFiles, _
i As Integer, stbar As Boolean, clTarget As Range, iLastRow As Long
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 'лист не пустой
'определяем ячейку, в которую будем копировать
' до первого копирования iLastRow=0
Set clTarget = shTarget.Range("a1"

.Offset(iLastRow, 0)
If blInsertNames Then
clTarget = ">>> " & wbSrc.Name & " -- " & shSrc.Name
Set clTarget = clTarget.Offset(1, 0)
End If
shSrc.UsedRange.Copy clTarget
'определяем последний заполненный ряд для следующего копирования _
4 - это колонка, по которой смотрим последнюю ячейку, можно дописать +1 _
или больше, если нужен пробел после импорта данных
iLastRow = shTarget.Cells(shSrc.Rows.Count, 1).End(xlUp).Row
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
ActiveWorkbook.Close
End If
End
save_err:
MsgBox "Книга не сохранена!", vbCritical
End With
End Sub
Заранее благодарен,
С уважением Константин.