Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Свод нескольких книг в одну через макрос - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Свод нескольких книг в одну через макрос (Макросы/Sub)
Свод нескольких книг в одну через макрос
Franchesko Дата: Вторник, 05.04.2016, 22:47 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2003
В общем использую макрос для сводки реестра. (Есть несколько книг, по несколько листов в каждой, примерно по 7 листов) Мне нужно некоторые определенные листы в один итоговый файл.
Использую данный макрос:
[vba]
Код
Sub Svodka_reestra02()

Const strStartDir = "c:\test" 'папка, с которой начать обзор файлов
Const strSaveDir = "c:\test\result" 'папка, в которую будет предложено сохранить результат
Const blInsertNames = False  'вставлять строку заголовка (книга, лист) перед содержимым листа

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)
    Sheets("Например Лист 4").Cells.ClearContents 'Очищает лист ( НЕСМОГ НАЙТИ СКРИПТ ЧТОБЫ ВЫДЕРНУТЬ ИНФУ ИЗ ОПРЕДЕЛЕННЫХ ЛИСТОВ, ПОЭТОМУ ПРОСТО УДАЛИЛ НЕНУЖНЫЕ)
    Sheets("Например Лист 6").Cells.ClearContents
    Sheets("Например Лист 7").Cells.ClearContents
    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
End Sub
[/vba]

После запуска макроса выдает ошибку:
Цитата
Run-time error '1004':

Данные не могут быть вставлены из-за несоответствия формы и размеров области копирования и области вставки. Выполните одно из следующих действий:
- Выберите и вставьте одну ячейку;
- Выберите и вставьте прямоугольник соответствующего размера и формы.


При запросе "Debug" Грешит на эту строку:
Цитата
shSrc.UsedRange.Copy clTarget


В общем кто сталкивался с такой проблемой, прошу откликнуться... :(
 
Ответить
СообщениеВ общем использую макрос для сводки реестра. (Есть несколько книг, по несколько листов в каждой, примерно по 7 листов) Мне нужно некоторые определенные листы в один итоговый файл.
Использую данный макрос:
[vba]
Код
Sub Svodka_reestra02()

Const strStartDir = "c:\test" 'папка, с которой начать обзор файлов
Const strSaveDir = "c:\test\result" 'папка, в которую будет предложено сохранить результат
Const blInsertNames = False  'вставлять строку заголовка (книга, лист) перед содержимым листа

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)
    Sheets("Например Лист 4").Cells.ClearContents 'Очищает лист ( НЕСМОГ НАЙТИ СКРИПТ ЧТОБЫ ВЫДЕРНУТЬ ИНФУ ИЗ ОПРЕДЕЛЕННЫХ ЛИСТОВ, ПОЭТОМУ ПРОСТО УДАЛИЛ НЕНУЖНЫЕ)
    Sheets("Например Лист 6").Cells.ClearContents
    Sheets("Например Лист 7").Cells.ClearContents
    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
End Sub
[/vba]

После запуска макроса выдает ошибку:
Цитата
Run-time error '1004':

Данные не могут быть вставлены из-за несоответствия формы и размеров области копирования и области вставки. Выполните одно из следующих действий:
- Выберите и вставьте одну ячейку;
- Выберите и вставьте прямоугольник соответствующего размера и формы.


При запросе "Debug" Грешит на эту строку:
Цитата
shSrc.UsedRange.Copy clTarget


В общем кто сталкивался с такой проблемой, прошу откликнуться... :(

Автор - Franchesko
Дата добавления - 05.04.2016 в 22:47
_Boroda_ Дата: Вторник, 05.04.2016, 23:09 | Сообщение № 2
Группа: Модераторы
Ранг: Экселист
Сообщений: 9374
Репутация: 3947 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Пробегитесь по макросу пошагово (через F8) и проверьте место вставки на наличие объединенных ячеек
Хотя да, как Ярослав ниже сказал, скорее всего диапазон превышен. Попробуйте переписать строку с ошибкой примерно вот так (в первых 2-х строках А и 1 можно написать свои)
[vba]
Код
r_ = shSrc.Range("A" & shSrc.Rows.Count).End(xlUp).Row'номер последней заполненной строки в столбце А
c_ = shSrc.Cells(1, shSrc.Columns.Count).End(xlToLeft).Column'номер последнего заполненного столбца в строке 1
shSrc.Range("A1").Resize(r_, c_).Copy clTarget
[/vba]


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеПробегитесь по макросу пошагово (через F8) и проверьте место вставки на наличие объединенных ячеек
Хотя да, как Ярослав ниже сказал, скорее всего диапазон превышен. Попробуйте переписать строку с ошибкой примерно вот так (в первых 2-х строках А и 1 можно написать свои)
[vba]
Код
r_ = shSrc.Range("A" & shSrc.Rows.Count).End(xlUp).Row'номер последней заполненной строки в столбце А
c_ = shSrc.Cells(1, shSrc.Columns.Count).End(xlToLeft).Column'номер последнего заполненного столбца в строке 1
shSrc.Range("A1").Resize(r_, c_).Copy clTarget
[/vba]

Автор - _Boroda_
Дата добавления - 05.04.2016 в 23:09
SLAVICK Дата: Вторник, 05.04.2016, 23:22 | Сообщение № 3
Группа: Модераторы
Ранг: Старожил
Сообщений: 1841
Репутация: 614 ±
Замечаний: 0% ±

2007,2010,2013,2016
Может у Вас usedrange до последней строки или столбца?
Тогда выдаст такую ошибку, поскольку не может скопировать весь столбец ниже 1-й строки.
Или в книге - приемнике всего 65тыс строк а Вы пытаетесь скопировать больше...


Иногда все проще чем кажется с первого взгляда.
 
Ответить
СообщениеМожет у Вас usedrange до последней строки или столбца?
Тогда выдаст такую ошибку, поскольку не может скопировать весь столбец ниже 1-й строки.
Или в книге - приемнике всего 65тыс строк а Вы пытаетесь скопировать больше...

Автор - SLAVICK
Дата добавления - 05.04.2016 в 23:22
Franchesko Дата: Понедельник, 11.04.2016, 11:22 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2003
_Boroda_, Спасибо, попробую переписать строку, результат отпишу здесь.
 
Ответить
Сообщение_Boroda_, Спасибо, попробую переписать строку, результат отпишу здесь.

Автор - Franchesko
Дата добавления - 11.04.2016 в 11:22
Franchesko Дата: Понедельник, 11.04.2016, 11:25 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2003
SLAVICK, Посмотрел, скрытых столбцов или строк я не нашёл...
Нет, у меня далеко не 65тыс. строк...

P.S. А никто не знает, что дописать в скрипт, чтобы он копировал именно из определенных листов???
Вот в моем примере, я просто удаляю ненужные листы, а можно же прописать так, чтобы он копировал определенные листы?!
 
Ответить
СообщениеSLAVICK, Посмотрел, скрытых столбцов или строк я не нашёл...
Нет, у меня далеко не 65тыс. строк...

P.S. А никто не знает, что дописать в скрипт, чтобы он копировал именно из определенных листов???
Вот в моем примере, я просто удаляю ненужные листы, а можно же прописать так, чтобы он копировал определенные листы?!

Автор - Franchesko
Дата добавления - 11.04.2016 в 11:25
SLAVICK Дата: Понедельник, 11.04.2016, 11:33 | Сообщение № 6
Группа: Модераторы
Ранг: Старожил
Сообщений: 1841
Репутация: 614 ±
Замечаний: 0% ±

2007,2010,2013,2016
SLAVICK, Посмотрел, скрытых столбцов или строк я не нашёл...

А кто писал про скрытые строки или столбцы?
я писал:
Может у Вас usedrange до последней строки или столбца?

Нажмите CTRL END на листе - посмотрите куда "закинет" курсор
А никто не знает, что дописать в скрипт, чтобы он копировал именно из определенных листов???

[vba]
Код
wbSrc.Sheets("nameList").UsedRange.Copy clTarget
[/vba]
где nameList - имя листа.


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
SLAVICK, Посмотрел, скрытых столбцов или строк я не нашёл...

А кто писал про скрытые строки или столбцы?
я писал:
Может у Вас usedrange до последней строки или столбца?

Нажмите CTRL END на листе - посмотрите куда "закинет" курсор
А никто не знает, что дописать в скрипт, чтобы он копировал именно из определенных листов???

[vba]
Код
wbSrc.Sheets("nameList").UsedRange.Copy clTarget
[/vba]
где nameList - имя листа.

Автор - SLAVICK
Дата добавления - 11.04.2016 в 11:33
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Свод нескольких книг в одну через макрос (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2016 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!