从多个工作簿复制粘贴一行到主工作簿

Question

I Have the below code to perform certain action. while I need to add an additional action of copying row 10 from sheet 2 with name "Site Creation Template(Project)" from multiple workbooks as in below.

I have tried several other possible combinations available in the web but it returns either wrong value or just blank.

Can anyone help me on this?

PS: Im just a starter in 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

I'm not sure which part you were having trouble with but try this

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