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

Posted by obzor under VBA

Сбор макросом рабочих листов из внешних Excel файлов с последующим выполнением другого макроса-научите, пожалуйста. Использую прекрасный макрос с форума,-спасибо Форуму-Учителю. Макрос умеет открывать много файлов в одну книгу-подшивку; рабочие листы при этом именуются по имени файлов.
Подскажите, пожалуйста, есть ли макрос который бы ВЫПОЛНЯЛСЯ при открытии-вставке, импорте файлов в листы. То есть, что нужно добавить в пропись макроса, чтобы, например, пустые строки в импортируемых файлах удалялись сразу же или в момент вставки файла-таблицы. Все внешние файлы состоять из одной, хотя и большой, таблицы, в которой встречаются пустые элементы или строки.

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

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

Sub DelRows()
    Application.ScreenUpdating = False: On Error Resume Next
    ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Случайные статьи

• Массовое открытие гиперссылок в браузере
• Как запретить ввод определённых символов в Edit?
• Любопытные факты
• Как организовать поиск по 2 полям с помощью like?
• Checkbox в javascript
• Зачем делать ADOQuery1.Close перед изменением SQL запроса?
• Функция меняет картинку на рабочем столе и сохраняет её
• Формирование ответа на AJAX-запрос
• Остановить программу на определенное время
• Взять кадр из видео без остановки видео потока (BASSVIDEO)