Макрос импорта Ексель файлов из папки в листы одной книги с последующим выполнения макросов.СПБ.

[as-is]

Сбор макросом рабочих листов из внешних Excel файлов с последующим выполнением другого макроса-научите, пожалуйста. Использую прекрасный макрос с форума,-спасибо Форуму-Учителю. Макрос умеет открывать много файлов в одну книгу-подшивку; рабочие листы при этом именуются по имени файлов.
Подскажите, пожалуйста, есть ли макрос который бы ВЫПОЛНЯЛСЯ при открытии-вставке, импорте файлов в листы. То есть, что нужно добавить в пропись макроса, чтобы, например, пустые строки в импортируемых файлах удалялись сразу же или в момент вставки файла-таблицы. Все внешние файлы состоять из одной, хотя и большой, таблицы, в которой встречаются пустые элементы или строки. Отдельно такой макрос для удаления я использую (приведён в конце), но приходится вручную.
-----------------------------------------------------
Sub CombineWorkbooks()
Dim FilesToOpen
Dim x As Integer
On Error GoTo ErrHandler
Application.ScreenUpdating = False
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
MultiSelect:=True, Title:="Files to Merge")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "Не выбрано ни одного файла!"
GoTo ExitHandler
End If
x = 1
While x <= UBound(FilesToOpen)
Workbooks.Open Filename:=FilesToOpen(x)
Sheets().Move After:=ThisWorkbook.Sheets(ThisWork book.Sheets.Count)
x = x + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
-----------------------------------------------------
ИЛИ,- Необходимо сделать так, чтобы файлы открывались в листы-заготовки той книги, из которой собственно они сейчас и вызываются, и открываются, А НЕ СОЗДАВАЛИ бы новые рабочие листы, как это происходит сейчас.
Возможно подсказка в следующем макросе (снова спасибо форумчанам). Данный макрос вставляет два файла (таблицы). А как сделать, чтобы вставлялись таблицы из всех Ексель файлов, которые в папке или был вариант выбора файлов из списка. Последнее как раз и реализовано в макросе, который выше. Никак не могу скрестить эти два макроса.
-----------------------------------------------------
Sub Main()
Dim i As Integer
Application.ScreenUpdating = False
Const myPath = "C:\TEMP" 'Подставьте требуемый путь к папке.
For i = 1 To 2
With ThisWorkbook.Sheets(i)
Workbooks.Open Filename:=myPath & Application.PathSeparator & i & ".xls"
Cells.Copy .[A1]
ActiveWorkbook.Close SaveChanges = False
End With
Next
End Sub
-----------------------------------------------------
Например, я создаю основную книгу с десятью рабочими листами - пустыми, но с макросами или функциями в тех ячейках, которые не будут заняты импортированными данными. После этого использую приведённый макрос и открываю 10 внешних Ексель файлов.
**В идеале число листов основного файла-книги на лету создаётся и зависит от того, сколько выбрано файлов для импорта.
Чем вызвана проблема, - я не смог найти макрос, который бы исполнялся сразу для всех рабочих листов. ("Выполнение макроса во всех листах" - форум ещё за 2008, - виноват, ничего не понял). Таким образом попробую обойти проблему, зашивая макросы в рабочие листы-заготовки. И если внешние файлы (они все стандартны) будут в них открываться, простите за наивность, то макросы и будут исполняться.
Буду очень признателен за решение. Рад заочному знакомству с профессионалами.
Файлы не присоединяю - вся моя проблема в приведённых макросах. Спасибо огромное.
***
Макрос удаления, который использую я, - удаляет строки с нулевым элементом в колонке
-----------------------------------------------------
Sub DeleteEmptyRows()
LastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = LastRow To 1 Step -1
If Application.CountA(Rows(r).Columns( 9)) = 0 Then Rows(r).Delete
Next r
End Sub
-----------------------------------------------------

[A2B]

Вот макрос который собирает несколько файлов Excel в 1 лист.
Врать не буду, писал не сам, дёрнул на каком-то форуме (может и на этом). Автору ещё раз большое спасибо.

Макрос дорабатывал под себя, дополнительное форматирование и т.д. (то что тебе нужно) вставляешь после строки ".StatusBar = False"

Удачи!

Sub Макрос1()

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", , "Объединить файлы", , 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
'
' Макрос1 Макрос
' Макрос записан 28.01.2010 (Admin)
'
' Сочетание клавиш: Ctrl+z
'
End Sub

[Dophin]

Файлы не присоединяю - вся моя проблема в приведённых макросах.

крайне спорный вывод, вычитывать Ваш код с листа нет никакого желания.

для обработки всех листов в книге используйте код типа

dim sh as worksheet
for each sh in worksheets
бла бла бла (ваша обработка)
next sh

вставляйте в конец макроса который собирает книги в одну

[as-is]

Выдает, к сожалению, ошибку в строке
Set clTarget = shTarget.Range("A1").Offset(shTarge t.Range("A1").SpecialCells(xlCellTy peLastCell).Row, 0)
Завтра буду пробовать разобрать код.
Спасибо.

[Dophin]

пробелы лишние не видите? или это так и надо?

[SAS888]

Вы не указали, все листы выбранных книг нужно копировать или нет. Сколько их, и как при этом называть создаваемые листы.
Пусть, например, все открываемые книги имеют 1 лист. Тогда скопировать их в одну книгу, присвоить имя согласно имени файла и удалить пустые строки можно так:

Sub CombineWorkbooks()
    Dim wb As Workbook, Nm As String, i As Integer, j As Long
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True: .Title = "Files to Merge": .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        For i = 1 To .SelectedItems.Count
            Set wb = Workbooks.Open(Filename:=.SelectedItems(i))
            Nm = Replace(wb.Name, ".xls", "")
            On Error Resume Next: ThisWorkbook.Sheets(Nm).Delete: On Error GoTo 0
            ActiveSheet.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            ActiveSheet.Name = Nm: wb.Close False
            With ActiveSheet.UsedRange
                For j = .Row + .Rows.Count - 1 To 1 Step -1
                    If Rows(j).Text = "" Then Rows(j).Delete
    Next: End With: Next: End With
End Sub

Пример файла во вложении. Если такой лист уже существует, то он будет обновлен.

[as-is]

1.Выбранные книги содержат только по одному листу.
2.Приведённый код делает в принципе тоже, что и было. Но выскакивает ошибка при некорректном представлении имени открываемого файла, что не принципиально.
3. Ещё одна очень важная деталь - я удаляю не только пустые строки, но и строки в которых есть хотя бы одна пустая ячейка (макрос такого действия был приведён ранее - еще раз его вставлю ниже)
----------------------------------------------------------------------
Sub DeleteEmptyRows()
LastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = LastRow To 1 Step -1
If Application.CountA(Rows(r).Columns( 9)) = 0 Then Rows(r).Delete
Next r
End Sub
----------------------------------------------------------------------
Возможно моя ошибка, - требуется, чтобы открываемые книги (файлы) копировались в уже существующие листы книги, из которой они вызываются (открываются).
То есть проблема не в том, как подшить файлы в одной книге и дать листам имена файлов.
Проблема - вставить файлы в уже существующие листы, в которых имеются макросы обработки вставляемого.
Может это слишком заумно, но проблема выросла из задачи, - как выполнить макрос одновременно для всех листов книги. Я уже научился открывать файлы в листы (меня спасает то, что все вставляемые книги содержат по одному листу); нашел макрос для обработки каждого листа. Но бьюсь на автоматизацией обработки всех рабочих листов. Спасибо

[as-is]

""""пробелы лишние не видите? или это так и надо?"""""
Увидел, потому что уже утро, Спасибо.
Но
SpecialCells(xlCellTy peLastCell)
""peLastCell""
ещё не увидел, потому что утро и ещё не вечер. Спасибо, учусь.

[SAS888]

А зачем иметь кучу листов, да еще и с кучей макросов? Не проще ли иметь один макрос, который запускается по событию книги Workbook_NewSheet(ByVal Sh As Object). Т.е. при каждом добавлении нового листа.

[as-is]

SpecialCells(xlCellTypeLastCell), - Все просто. И ещё раз спасибо.