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

Вход

Регистрация

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

 

= Мир MS Excel/Не удается скопировать данные из одной книги в другую - Страница 2 - Мир MS Excel

Старая форма входа
  • Страница 2 из 2
  • «
  • 1
  • 2
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Не удается скопировать данные из одной книги в другую (Макросы/Sub)
Не удается скопировать данные из одной книги в другую
Franchesko Дата: Воскресенье, 03.04.2016, 17:02 | Сообщение № 21
Группа: Пользователи
Ранг: Прохожий
Сообщений: 4
Репутация: 0 ±
Замечаний: 0% ±

Excel 2003
KuklP, Помогите мне пожалуйста, не могу понять в чем дело...
В общем использую макрос для сводки реестра. (Есть несколько книг, по несколько листов в каждой, примерно по 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


Помогите пожалуйста.... =(
О_очень буду благодарен... :(
[moder]Читаем Правила форума, создаём свою тему[/moder]


Сообщение отредактировал Pelena - Воскресенье, 03.04.2016, 17:21
 
Ответить
СообщениеKuklP, Помогите мне пожалуйста, не могу понять в чем дело...
В общем использую макрос для сводки реестра. (Есть несколько книг, по несколько листов в каждой, примерно по 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


Помогите пожалуйста.... =(
О_очень буду благодарен... :(
[moder]Читаем Правила форума, создаём свою тему[/moder]

Автор - Franchesko
Дата добавления - 03.04.2016 в 17:02
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Не удается скопировать данные из одной книги в другую (Макросы/Sub)
  • Страница 2 из 2
  • «
  • 1
  • 2
Поиск:

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