excelvbaconsolidation

copy specific data from multiple workbooks


Im new to VBA and I have been trying to create a program to copy specific range from multiple workbooks having data in sheet 2 to a master workbook sheet 2 .

COPY Condition: the column range will be A20 to AS20 while the row range will depend upon the last cell having data in column R.

PASTE Condition: consecutively all copied cells should be pasted with one blank row in between starting from row A20

COPY paste condition: range D5 : D18 from source books to the master sheet, on a overlapping manner since the range will be same in all source books.

I came till the below stage, but no idea to proceed further. Made some corrections but didnt work well.

Prog:

    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

Solution

  • check this. See comments in code, if questions - put comments to answer. Hope you find something new. You have to put this code to the Module in Master workbook.

    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