Новости:

Новая редакция правил форума: 2.4. Если вопрос или ответ содержится во вложенном файле, все-равно кратко описывайте в сообщении вопрос или суть решения. Это необходимо, чтобы тему можно было найти через поиск.

Главное меню

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

Автор Markovki, 20.02.2012, 15:37

« назад - далее »

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

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

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

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

Markovki

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

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

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

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

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

Markovki

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

kuklp

#4
Попробуйте:
   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

И не надо копировать листы, переименовывать и т.д.
Я, как всегда, чертовски адекватен... Email: pilipnikop@yandex.ua WM Z206653985942, R334086032478, U238399322728, E332314026771

Markovki

#5
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
Я, как всегда, чертовски адекватен... Email: pilipnikop@yandex.ua WM Z206653985942, R334086032478, U238399322728, E332314026771

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

#9
Так сделайте xlPasteValues, 2, 0
пропускать не будет.
Тьфу-ты, посмотрел файлы, дошло наконец. У Вас же в источниках автофильтры стоят. Конечно будет пропускать.
Я, как всегда, чертовски адекватен... Email: pilipnikop@yandex.ua WM Z206653985942, R334086032478, U238399322728, E332314026771

Markovki

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

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

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


kuklp

Все корректно заполняет, см. файл. А если при этом надо еще и _автофильтр_ы оставить, то такой вариант.
Я, как всегда, чертовски адекватен... Email: pilipnikop@yandex.ua WM Z206653985942, R334086032478, U238399322728, E332314026771

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

#13
Не надо. Сделайте так:
   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

Я, как всегда, чертовски адекватен... Email: pilipnikop@yandex.ua WM Z206653985942, R334086032478, U238399322728, E332314026771

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

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

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