Сводная таблица

[Markovki]

Здравствуйте форумчане, переделал небольшой скрипт под свои нужды, он копирует листы "НПО" из выбранных файлов в текущую книгу и называет их именами файлов:

Код Выделить Развернуть

Sub Добавление_файлов_с_переименованием_листов()
Dim FilesToOpen
Dim strFileTitle As String
Dim x As String
On Error GoTo ErrHandler
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
MultiSelect:=True, Title:="Выберите необходимые файлы")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "Операция отменена пользователем"
GoTo ExitHandler
End If
x = 1
While x <= UBound(FilesToOpen)
Workbooks.Open Filename:=FilesToOpen(x)
FName = ActiveWorkbook.Name
Sheets("НПО").Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Sheets("НПО").Name = FName
x = x + 1
Workbooks(FName).Close
Wend
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub

1. Как убрать .xls из названия листа?
2. Если имя файла превышает допустимое количество символов (кажется 31), то выдается ошибка и выполнение макроса останавливается, как обрезать название листа или как еще можно решить данную проблему?
3. Помогите пожалуйста... хотя бы дайте толчок, как свести все добавленные листы в один, точнее не листы а значения из требуемого диапазона на первый лист (везде диапазон D13:J897, а в сводном листе "НПО_ИТОГ" = диапазон D12:J896, т.е. смещается на одну строку), с учетом того, что: 1) диапазон не меняется 2) Название листов динамическое 3) количество добавляемых листов всегда разное

Прилагаю архив с фалом "НПО", куда и должно всё сводиться и три файла для добавления в свод

[Markovki]

Есть идея, чтобы там же в цикле сразу сделать добавление данных на первый лист, но как не просто тупо скопировать, а добавить значение, тоже не знаю..

Или уже когда все листы добавлены, определить количество и названия листов, а затем суммировать значения со всех листов данного диапазона в один..

В общем в теории примерно представляю, но как это реализовать на практике не знаю

[Markovki]

Более всего, конечно меня интересует помощь в третьем вопросе, так как сводить вручную более сотни файлов, вообще не прокатит, да и времени у меня очень мало..

Я так понимаю, что вот здесь:

Sheets("НПО").Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

ThisWorkbook.Sheets("НПО").Name = FName

вместо знаков вопросов(пардон, получился смайлик)) должна быть строка позволяющая добавить значения диапазона листа "НПО" в аналогичную таблицу листа "НПО ИТОГ"
Уважаемые гуру!!! Обращаюсь к вам, может это просто невозможно? Может я зря уже третий день пыхтю, пытаясь разобраться в особенностях синтаксиса?!
Если это так, то печально
но интуиция и понимание элементарных принципов программирования, подсказывают, что выход есть))

Причём скорость выполнения и оптимизация макроса меня сейчас явно не волнует))

[Markovki]

Может как вариант возможно сделать условный цикл, способный суммировать весь диапазон D12:J896 со всех листов, начиная со второго и до последнего и занести его в первый лист под названием "НПО_ИТОГ"? Что скажете? Как это возможно реализовать? Хотя бы элементарный пример...((

[kuklp]

Попробуйте:

Код Выделить Развернуть

   While x <= UBound(FilesToOpen)
       Workbooks.Open Filename:=FilesToOpen(x)
       fname = ActiveWorkbook.Name 'загоняем имя открываемого файла в переменную FName
       'MsgBox "Имя файла: " & FName & "" 'вывожу сообщение, для проверки имени файла
       Sheets("НПО").Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 'копируем лист
       x = x + 1
       Workbooks(fname).Close 'Закрывает файл определяя его по переменной FName
       fname = Left$(Split(fname, ".")(0), 30)
       ThisWorkbook.Sheets("НПО").Name = fname 'переименовываем созданный лист по названию файла
   Wend
но вообще-то галиматья. После того, как открыли очередную книгу...
Так:

Код Выделить Развернуть

   While x <= UBound(FilesToOpen)
       Workbooks.Open Filename:=FilesToOpen(x)
       ActiveWorkbook.Sheets("НПО").Range("D12:J897").Copy
       ThisWorkbook.Sheets("НПО ИТОГ").[D12].PasteSpecial xlPasteValues, 2, -1
       Workbooks(Dir(FilesToOpen(x))).Close 0   'Закрывает файл
       x = x + 1
   Wend
И не надо копировать листы, переименовывать и т.д.

[Markovki]

KukIp благодарю за ответ, согласен с вами, что копирование только замедляет процесс обработки, но такое уж требование...
Подкорректировал диапазон (изначально неправильно его озвучил):

Код Выделить Развернуть

  While x <= UBound(FilesToOpen)
       Workbooks.Open Filename:=FilesToOpen(x)
       ActiveWorkbook.Sheets("НПО").Range("D13:J897").Copy
       ThisWorkbook.Sheets("НПО_ИТОГ").[D12].PasteSpecial xlPasteValues, 2, -1
       Workbooks(Dir(FilesToOpen(x))).Close 0   'Закрывает файл
       x = x + 1
   Wend
Результат выполнения: заполнение происходит не по порядку, а если быть более точным, заполняются первые строки, возможно причина в том, что в выбранном диапазоне много пустых данных.
+ перед закрытием каждого открываемого макросом файла выскакивает сообщение "Буфер обмена содержит... для других приложений", что тоже только создает неудобства.
К тому же не происходит добавление листов в текущую книгу..

P/S/ Поясните пожалуйста, что это и как этим пользоваться:

Код Выделить Развернуть

PasteSpecial xlPasteValues, 2, -1
Ну Паст понятно))) а всё остальное?

[kuklp]

xlPasteValues, 2, -1
3 параметра: значения, сложить, пропускать пустые ячейки(можно и удалить этот параметр)

файла выскакивает сообщение "Буфер обмена содержит..

чтоб не выскакивало, вначале макроса впишите:
application.displayalerts=0

[Markovki]

Архив почистил от всякого хлама, обоновил и перезалил в первом посте.

Первый предложенный ваш код действительно решает первые два вопроса :

Код Выделить Развернуть

fname = Left$(Split(fname, ".")(0), 30

Если я правильно понял:
Left$ - переменная
Split - функция обрезки...?, где говорится, что макрос "возьмет" всё, до первой попавшейся точки?

[Markovki]

Сделал вот так:

Код Выделить Развернуть

   While x <= UBound(FilesToOpen)
        Workbooks.Open Filename:=FilesToOpen(x)
        fname = ActiveWorkbook.Name
        Sheets("ÍÏÎ").Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        ThisWorkbook.Sheets("НПО").Range("D13:J897").Copy
        ThisWorkbook.Sheets("НПО_ИТОГ").[D12].PasteSpecial xlPasteValues, 2, -1
        x = x + 1
        Workbooks(fname).Close
        fname = Left$(Split(fname, ".")(0), 30)
        ThisWorkbook.Sheets("НПО").Name = fname
    Wend

поэкспериментировал с
xlPasteValues, 2, -1
толку никакого, результат тотже... видимо пропускает всё-таки пустые ячейки.

[kuklp]

Так сделайте xlPasteValues, 2, 0
пропускать не будет.
Тьфу-ты, посмотрел файлы, дошло наконец. У Вас же в источниках автофильтры стоят. Конечно будет пропускать.

[Markovki]

Пробовал, ещё вчера, результат тотже, заполняет аналогично и некорректно...

Надо же)) всё гениальное просто)) KuklP, премного благодарен. 

Странно получается, мне казалось, что фильтры могут влиять только лишь отображение, а оказалось вон как) 

[kuklp]

Все корректно заполняет, см. файл. А если при этом надо еще и _автофильтр_ы оставить, то такой вариант.

[Markovki]

В общем, запустил файл, который вы прислали, фильтры не восстанавливаются, записал макрос добавления фильтра, убрал всё ненужное, получилось вот так: всё работает))

Код Выделить Развернуть

Sub Добавление_файлов_с_переименованием_листов()
    Dim FilesToOpen
    Dim strFileTitle As String
    Dim x As String
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    FilesToOpen = Application.GetOpenFilename _
                  (FileFilter:="Microsoft Excel Files (*.xls), *.xls", _
                   MultiSelect:=True, Title:="Выберите необходимые файлы")
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Операция отменена пользователем"
        GoTo ExitHandler
    End If
    x = 1
    Application.DisplayAlerts = 0
    While x <= UBound(FilesToOpen)
        Workbooks.Open Filename:=FilesToOpen(x)
        fname = ActiveWorkbook.Name
        Sheets("НПО").Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        ActiveWorkbook.Sheets("НПО").AutoFilterMode = 0
        ActiveWorkbook.Sheets("НПО").Range("D13:J897").Copy
        ThisWorkbook.Sheets("НПО_ИТОГ").[D12].PasteSpecial xlPasteValues, 2, -1
        x = x + 1
        Workbooks(fname).Close
        fname = Left$(Split(fname, ".")(0), 30)
        ThisWorkbook.Sheets("НПО").Name = fname
    Wend
    Sheets("НПО_ИТОГ").Activate
    Range("D11:D896").Select
    ActiveSheet.Range("$D$11:$D$901").AutoFilter Field:=1, Criteria1:="="
    ActiveSheet.Range("$D$11:$D$901").AutoFilter Field:=1, Criteria1:=">=1", _
    Operator:=xlAnd
ExitHandler:
    Application.DisplayAlerts = -1
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

[kuklp]

Не надо. Сделайте так:

Код Выделить Развернуть

   While x <= UBound(FilesToOpen)
       Workbooks.Open Filename:=FilesToOpen(x)
       fname = ActiveWorkbook.Name
       Sheets("НПО").Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
       Workbooks(fname).Sheets("НПО").AutoFilterMode = 0
       Workbooks(fname).Sheets("НПО").Range("D13:J897").Copy
       ThisWorkbook.Sheets("НПО_ИТОГ").[D12].PasteSpecial xlPasteValues, 2, -1
       x = x + 1
       Workbooks(fname).Close
       fname = Left$(Split(fname, ".")(0), 30)
       ThisWorkbook.Sheets("НПО").Name = fname
   WendЯ вообще-то имел ввиду фильтры в тех листах, к-рые копируем в книгу.
Еще бы добавил после всех dim'ов:

Код Выделить Развернуть

    ChDrive Left$(ThisWorkbook.Path, 1)
    ChDir ThisWorkbook.Path

[Markovki]

Не надо. Сделайте так:
Код:
    While x <= UBound(FilesToOpen)
        Workbooks.Open Filename:=FilesToOpen(x)
        fname = ActiveWorkbook.Name
        Sheets("НПО").Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        Workbooks(fname).Sheets("НПО").AutoFilterMode = 0
        Workbooks(fname).Sheets("НПО").Range("D13:J897").Copy
        ThisWorkbook.Sheets("НПО_ИТОГ").[D12].PasteSpecial xlPasteValues, 2, -1
        x = x + 1
        Workbooks(fname).Close
        fname = Left$(Split(fname, ".")(0), 30)
        ThisWorkbook.Sheets("НПО").Name = fname
    Wend

Извините за тугость, но кажется у меня точно также...

Я вообще-то имел ввиду фильтры в тех листах, к-рые копируем в книгу.

Ага... это тоже желательно оставить...