Страницы: 1
RSS
VBA Копирование содержимого всех книг в папке в одниу
 
Добрый день.
Я пробовал эту задачу решить макрорекодером, но получилось только если задать определенные имена документов.

Задача:
Поочередно открыть каждую книгу в папке, снять защиту с листа, скопировать диапазон (например A3:J10), вставить в агрегирующую книгу, в ячейку A3. Затем тоже самое для следующей книги из папки, но вставить уже на 11 сток ниже предыдущего диапазона. И так далее, пока не закончатся файлы в папке.

Такое возможно сделать?

Спасибо!
 
Цитата
Alexander Kuznetsov пишет:
Такое возможно сделать?
возможно
Чебурашка стал символом олимпийских игр. А чего достиг ты?
Тишина - самый громкий звук


https://github.com/nervgh
 
Все, что нужно для решения Вашей задачи:
Просмотреть все файлы в папке
Как собрать данные с нескольких листов или книг?
Про защиту листов макросом
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
А как выделить третью пустую ячейку после заполненной в столбце?
Например, если последняя заполненная ячейка A17, то выделить A20.
 
Как определить последнюю ячейку на листе через VBA?
Останется только прибавить к полученному 3.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
последняя.offset(3).select
 
Код
Sub Get_All_File_from_Folder()
    Dim sFolder As String, sFiles As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""

        Workbooks.Open sFolder & sFiles
 '       ActiveWorkbook.Close True
     Range("A2:J10").Select
    Selection.Copy
    Windows("Bonus.xlsm").Activate
            ActiveSheet.Paste Cells(Rows.Count, 1).End(xlUp).Offset(3)
        sFiles = Dir
    Loop
    Application.ScreenUpdating = True
End Sub


получилось так, но слетает при вставке форматирование ячеек.Как сохранить форматирование?
Изменено: Alexander Kuznetsov - 14.01.2013 16:53:22
 
неплохо бы закрывать книги после копирования - а Вы взяли и закомментировали эту строку. И активировать ячейки и книгу необязательно.

Код
Sub Get_All_File_from_Folder()
    Dim sFolder As String, sFiles As String
    Dim wsSh As Worksheet, llastRow As Long
    Set wsSh = ActiveSheet

    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
        Workbooks.Open sFolder & sFiles
        Range("A2:J10").Copy wsSh.Cells(wsSh.Rows.Count, 1).End(xlUp).Offset(3)
        ActiveWorkbook.Close 0
        sFiles = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Цитата
The_Prist пишет:
неплохо бы закрывать книги после копирования - а Вы взяли и закомментировали эту строку. И активировать ячейки и книгу необязательно.
Да!
Так намного лучше, спасибо!
Но ширина ячеек не совпадает с оригиналом. Как сохранить форматирование?
Изменено: Alexander Kuznetsov - 15.01.2013 13:07:49
 
Открывать книги неплохо бы в режиме "Только чтение".
Чтобы  ширина ячеек совпадала с оригиналом, при копировании
примените специальную вставку PasteSpesial с типом xlPasteColunmWidths
 
Цитата
Kuzmich пишет:
Открывать книги неплохо бы в режиме "Только чтение".
Чтобы  ширина ячеек совпадала с оригиналом, при копировании
примените специальную вставку PasteSpesial с типом xlPasteColunmWidths

А куда именно в код выше добавить PasteSpecial xlPasteColumnWidths?
 
Вы скопировали диапазон А2:А10  и вставили его  в wsSh.
Range("A2:J10").Copy wsSh.Cells(wsSh.Rows.Count, 1).End(xlUp).Offset(3)
теперь вставляйте ширину столбцов
wsSh.Cells(wsSh.Rows.Count, 1).End(xlUp).Offset(3). PasteSpecial xlPasteColumnWidths
 
Нет, так будет ошибка. При копировании методом Copy и указанием для него сразу диапазона назначения буфер обмена очищается. чтобы нормально работало делать надо так:
Код
Range("A2:J10").Copy
wsSh.Cells(wsSh.Rows.Count, 1).End(xlUp).Offset(3).PasteSpecial xlPasteAll
wsSh.Cells(wsSh.Rows.Count, 1).End(xlUp).Offset(3).PasteSpecial xlPasteColumnWidths
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Спасибо The_Prist
Не знал, что буфер обмена очищается
Страницы: 1
Наверх