Страницы: 1
RSS
Сборка листов из разных книг в одну Только видимых
 
Доброе утро Уважаемые!

Есть очень шикарный и отлично работающий макрос -  Сборка листов из разных книг в одну, но столкнулся с мелким нюансом и не могу его обойти - нужно забирать только видимые листы с книг.

Возможно кто то сталкивался?

Спасибо
 
Я не сталкивался.
Но по тому макросу - замените копирование всех листов скопом на копирование по одному перебором, с отсеиванием скрытых.
 
Замените строку
Код
 Sheets().Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

упомянутого макроса на
Код
 Sheets(ArrSheetsVisible).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

где ArrSheetsVisible - предварительно заполненный массив имен видимых листов.
Владимир
 
Кусок кода с перебором!
Код
Sub test()
Dim sht As Worksheet
For Each sht In Worksheets
    If sht.Visible Then sht.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Next sht
End Sub
Изменено: Nordheim - 27.10.2017 16:09:29
"Все гениальное просто, а все простое гениально!!!"
 
Цитата
Nordheim написал:
Sheets().Visible
- где такое работает?
 
Я переделал код. Не заметил что там нет цикла а листы копируются скопом.
"Все гениальное просто, а все простое гениально!!!"
 
При копировании по одному листу (в отличие от способа из #3) могут возникнуть проблемы с формулами (и гиперссылками), содержащими перекрестные ссылки между копируемыми листами.
Владимир
 
есть еще вот такой макрос - поинтереснеее
сорс - http://www.planetaexcel.ru/techniques/3/49/ - Слава 07.10.2012 13:35:48
Код
Sub Объединение_множества_книг_в_один_лист() 'работает, объединяет листы выбранных книг в одну книгу (без консолидации) v. 1.01
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 = Application.GetOpenFilename _
(FileFilter:="All files (*.*), *.*", _
MultiSelect:=True, Title:="Files to Merge")

'.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(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("Результат", "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
'clb
End Sub
Изменено: aimv - 27.10.2017 22:11:29
Страницы: 1
Наверх