скопировать вставить одну строку из нескольких рабочих книг в основную рабочую книгу

Question

У меня есть приведенный ниже код для выполнения определенных действий. хотя мне нужно добавить дополнительное действие по копированию строки 10 из листа 2 с именем «Шаблон создания сайта (проект)» из нескольких рабочих книг, как показано ниже.

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

Может кто-нибудь помочь мне в этом?

PS: Я только начинающий в VBA.

    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 = 22
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(22, 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
        insertRow = masterBook.Sheets("Service Order Template").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
    Application.DisplayAlerts = False
    Application.Dialogs(xlDialogSaveAs).Show ThisWorkbook.Name, 51


End Sub

Answer 1

Я не уверен, с какой частью у вас были проблемы, но попробуйте это

Option Explicit

Sub CopyDataFromMultipleWorkbooksIntoMaster()

    Const TEMPLATE = "Service Order Template"
    Const SITE_TEMPLATE = "Site Creation Template(Project)"

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

    ' select folder
    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
            MsgBox "Cancelled selection", vbCritical
            Exit Sub
        End If
    End With
    'Debug.Print "BrowseFolder = " & BrowseFolder

    Dim wbMaster As Workbook, wsMaster As Worksheet
    Dim wbSource As Workbook, wsSource As Worksheet, rngSource As Range
    Dim f As Object, fname As String
    Dim lastSrcRow As Long
    Dim insertRow1 As Long, insertRow2 As Long, count As Long

    Set wbMaster = ThisWorkbook
    Set wsMaster = wbMaster.Sheets(TEMPLATE)

    insertRow1 = 22
    insertRow2 = 1 ' start of row 10 copies on sheet 2 of master

    Set oFolder = FSO.getfolder(BrowseFolder)
    count = 0

    ' scan files
    For Each f In oFolder.Files

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

            fname = BrowseFolder & Application.PathSeparator & f.Name
            'Debug.Print fname

            Set wbSource = Workbooks.Open(fname, False, True) ' open no link update, read-only
            Set wsSource = wbSource.Sheets(TEMPLATE)

            lastSrcRow = wsSource.Cells(Rows.count, 18).End(xlUp).Row

            Set rngSource = wsSource.Range("A22:AS" & lastSrcRow) ' AS=col45
            Debug.Print f.Name, wsSource.Name, rngSource.Address

            rngSource.Copy wsMaster.Cells(insertRow1, 1)
            insertRow1 = insertRow1 + rngSource.Rows.count + 1

            ' copy additional needed range D5 : D18 from source to range D5 on master
            wsSource.Range("D5:D18").Copy wsMaster.Range("D5")

            'copying row 10 from sheet 2 with name "Site Creation Template(Project)"
            wbSource.Sheets(SITE_TEMPLATE).Rows(10).EntireRow.Copy wbMaster.Sheets(2).Range("A" & insertRow2)
            insertRow2 = insertRow2 + 1

            wbSource.Close False
            count = count + 1
        End If
    Next

    ' if you don't need to highlight the whole row - remove the ".EntireRow" part ?---?---?----?
    wsMaster.Range("R20:R" & insertRow1 - 1).SpecialCells(xlCellTypeBlanks).EntireRow.Interior.Color = vbYellow

    End
    MsgBox count & " files processed", vbInformation
End Sub