копировать определенные данные из нескольких книг

Я новичок в VBA, и я пытался создать программу для копирования определенного диапазона из нескольких книг, содержащих данные на листе 2, на лист основной книги 2.

Условие копирования: диапазон столбцов будет от A20 до AS20, а диапазон строк будет зависеть от последней ячейки, содержащей данные в столбце R.

Условие PASTE: последовательно все скопированные ячейки должны быть вставлены с одной пустой строкой между ними, начиная со строки A20

Условие копирования и вставки: диапазон D5: D18 из исходных книг в мастер-лист с перекрытием, поскольку диапазон будет одинаковым для всех исходных книг.

Я дошел до нижнего этапа, но не знал, что делать дальше. Внесены некоторые исправления, но работать не удалось.

Прог:

    Sub copyDataFromMultipleWorkbooksIntoMaster()

Dim FileItem As Object
Dim oFolder As Object
Dim FSO As Object
Dim BrowseFolder As String

Dim masterBook As Workbook
Dim sourceBook As Workbook

Dim insertRow As Long
Dim copyRow As Long

insertRow = 20
Set masterBook = ThisWorkbook

Set FSO = CreateObject("Scripting.FileSystemObject")

        With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select the folder with source files"
        If Not .Show = 0 Then
            BrowseFolder = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    Application.ScreenUpdating = False


    Set oFolder = FSO.getfolder(BrowseFolder)

    masterBook.Sheets("Service Order Template").Cells.UnMerge


    For Each FileItem In oFolder.Files

       If FileItem.Name Like "*.xls*" Then



        Workbooks.Open (BrowseFolder & Application.PathSeparator & FileItem.Name)

       Set sourceBook = Workbooks(FileItem.Name)

           With sourceBook.Sheets("Service Order Template")
               .Cells.UnMerge
               copyRow = .Cells(Rows.Count, 18).End(xlUp).Row
               Range(.Cells(20, 1), .Cells(copyRow, 45)).Copy Destination:=masterBook.Sheets("Service Order Template").Cells(insertRow, 1)
               Application.CutCopyMode = False
               .Parent.Close SaveChanges:=False
           End With
           insertRow = masterBook.Sheets("Service Order Template").Cells(Rows.Count, 18).End(xlUp).Row + 2
       End If
    Next
    Application.ScreenUpdating = True
End Sub

excel vba consolidation
person wells    schedule 10.01.2020    source источник

Ответы (1)


arrow_upward
0
arrow_downward

Проверь это. Смотрите комментарии в коде, если вопросы - ставьте комментарии для ответа. Надеюсь, ты найдешь что-то новое. Вы должны поместить этот код в модуль в главной книге.

Sub copyDataFromMultipleWorkbooksIntoMaster()

Dim FileItem As Object
Dim oFolder As Object
Dim FSO As Object
Dim BrowseFolder As String

Dim masterBook As Workbook
Dim sourceBook As Workbook

Dim insertRow As Long
Dim copyRow As Long

' add variables for blank check
Dim checkRange As Range, r As Range

insertRow = 20
Set masterBook = ThisWorkbook

Set FSO = CreateObject("Scripting.FileSystemObject")

        With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select the folder with source files"
        If Not .Show = 0 Then
            BrowseFolder = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    Application.ScreenUpdating = False


    Set oFolder = FSO.getfolder(BrowseFolder)

    masterBook.Sheets("Service Order Template").Cells.UnMerge


    For Each FileItem In oFolder.Files

       If FileItem.Name Like "*.xls*" Then

        Workbooks.Open (BrowseFolder & Application.PathSeparator & FileItem.Name)

       Set sourceBook = Workbooks(FileItem.Name)

           With sourceBook.Sheets("Service Order Template")
               .Cells.UnMerge
               copyRow = .Cells(Rows.Count, 18).End(xlUp).Row
               Range(.Cells(20, 1), .Cells(copyRow, 45)).Copy Destination:=masterBook.Sheets("Service Order Template").Cells(insertRow, 1)

               ' copy additional needed range D5 : D18 from source to range D5 on master
               Range(.Cells(5, 4), .Cells(18, 4)).Copy Destination:=masterBook.Sheets("Service Order Template").Cells(5, 4)

               Application.CutCopyMode = False
               .Parent.Close SaveChanges:=False
          End With     
        masterBook.Sheets("Service Order Template").insertRow = .Cells(Rows.Count, 18).End(xlUp).Row + 2
       End If
    Next

    With masterBook.Sheets("Service Order Template")
        ' if you don't need to highlight the whole row - remove the ".EntireRow" part →---→---→----↓
        Range(.Cells(20, 18), .Cells(Rows.Count, 18).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Interior.Color = vbYellow
    End With

    Application.ScreenUpdating = True
End Sub
person Vitaliy Prushak    schedule 10.01.2020
comment
---- Set sourceBook = Workbooks.Open (FileItem.Name) 'книга с открытым исходным кодом ---- выдает ошибку. что именно здесь нужно делать? он говорит, что файл был перемещен, переименован или удален. - person wells; 10.01.2020
comment
Я отредактировал код, пропустил, извините. Здесь должно быть Set sourceBook = Workbooks.Open(BrowseFolder & Application.PathSeparator & FileItem.Name), чтобы указать полный путь к файлу - person Vitaliy Prushak; 10.01.2020
comment
Я сделал еще одну правку, попробуйте. Обратите внимание, что я протестировал код, и он работает правильно. См. эту ветку по возможным причинам, потому что код правильный. - person Vitaliy Prushak; 10.01.2020
comment
я получаю сообщение об ошибке, что мы не можем сделать это с объединенной ячейкой ... это одна из ошибок, с которыми я столкнулся ранее ... - person wells; 10.01.2020
comment
я решил это ... не могли бы вы помочь мне с моим последним комментарием ... - person wells; 10.01.2020
comment
Эта ошибка говорит о том, что excel не может что-то сделать (вы не указали, в какой строке появляется эта ошибка) с объединенными ячейками. Посмотрите свои файлы и проверьте, где у вас объединены ячейки? - person Vitaliy Prushak; 10.01.2020
comment
Я обычно объединяю ячейки в столбце К., в то время как ячеек может быть несколько .... Я надеюсь, что для этого должен быть способ - person wells; 10.01.2020
comment
Будет ли потеря данных, если эти ячейки не объединены? - person Vitaliy Prushak; 10.01.2020
comment
нет .. если не объединенные данные ячейки, если они видны в первой ячейке не объединенной версии, достаточно - person wells; 10.01.2020
comment
@wells Я на самом деле не понимаю, что вы хотите ... откуда копировать, куда вставлять ... Отредактируйте исходный пост, используя код, который вы получили к настоящему моменту, и добавьте свои другие требования. И обратите внимание - здесь нет стойки заказов, здесь есть место, где вам могут помочь в ваших усилиях. - person Vitaliy Prushak; 14.01.2020
comment
принято к сведению. Я новичок в этом сообществе .. Я учусь использовать здесь коды и выполнять их .... но возникает ошибка. Я сделаю правку с моими потребностями. Ваши советы очень ценятся. заранее спасибо - person wells; 14.01.2020
comment
@wells см. последнее изменение. Он основан на обновленном коде, который вы разместили в своем сообщении. Еще одна не совсем ясная вещь - highlight condition: highlight blank row in column R with range "R20:last valid cell" - применимо ли это к мастер-листу после того, как все копирование было выполнено (как я это сделал при редактировании)? - person Vitaliy Prushak; 14.01.2020
comment
Я буду использовать для него форматирование условий. пожалуйста, не обращайте внимания на эту часть. при запуске кода я получаю конец ошибки компиляции, если без блока, если - person wells; 14.01.2020
comment
@wells поправил, моя опечатка. По поводу выделения - если он вам не нужен - уберите блок With masterBook.Sheets("Service Order Template") ' if you don't need to highlight the whole row - remove the ".EntireRow" part →---→---→----↓ Range(.Cells(20, 18), .Cells(Rows.Count, 18).End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Interior.Color = vbYellow End With - person Vitaliy Prushak; 14.01.2020