В общем использую макрос для сводки реестра. (Есть несколько книг, по несколько листов в каждой, примерно по 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
Пробегитесь по макросу пошагово (через 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]
Пробегитесь по макросу пошагово (через 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
Может у Вас usedrange до последней строки или столбца? Тогда выдаст такую ошибку, поскольку не может скопировать весь столбец ниже 1-й строки. Или в книге - приемнике всего 65тыс строк а Вы пытаетесь скопировать больше...
Может у Вас usedrange до последней строки или столбца? Тогда выдаст такую ошибку, поскольку не может скопировать весь столбец ниже 1-й строки. Или в книге - приемнике всего 65тыс строк а Вы пытаетесь скопировать больше...SLAVICK
SLAVICK, Посмотрел, скрытых столбцов или строк я не нашёл... Нет, у меня далеко не 65тыс. строк...
P.S. А никто не знает, что дописать в скрипт, чтобы он копировал именно из определенных листов??? Вот в моем примере, я просто удаляю ненужные листы, а можно же прописать так, чтобы он копировал определенные листы?!
SLAVICK, Посмотрел, скрытых столбцов или строк я не нашёл... Нет, у меня далеко не 65тыс. строк...
P.S. А никто не знает, что дописать в скрипт, чтобы он копировал именно из определенных листов??? Вот в моем примере, я просто удаляю ненужные листы, а можно же прописать так, чтобы он копировал определенные листы?!Franchesko