Добрый день.
Господа, есть задача в сращивании нескольких книг в одну непрерывную структуру.
Есть готовый макрос, найденный на просторах интернета, который с этой задачей справляется, но есть необходимость "обрезать" первую строку (заголовки столбцов) в каждой сращиваемой книге. Помогите, пожалуйста, доработать данный скрипт.
Заранее благодарю!
Господа, есть задача в сращивании нескольких книг в одну непрерывную структуру.
Есть готовый макрос, найденный на просторах интернета, который с этой задачей справляется, но есть необходимость "обрезать" первую строку (заголовки столбцов) в каждой сращиваемой книге. Помогите, пожалуйста, доработать данный скрипт.
Код |
---|
Sub FiziK() Const strStartDir = "c:\test" 'папка, с которой начать обзор файлов Const strSaveDir = "c:\test\result" 'папка, в которую будет предложено сохранить результат Const blInsertNames = True 'вставлять строку заголовка (книга, лист) перед содержимым листа 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*", , "Join files", , 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(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 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("Result", "Excel Files (*.xlsx), *.xlsx", , "Save book") If VarType(arFiles) = vbBoolean Then 'если не выбрано имя GoTo save_err Else On Error GoTo save_err wbTarget.SaveAs arFiles End If End save_err: MsgBox "Book was not saved", vbCritical End With End Sub |