Copying all data from multiple files with 3 worksheets into a master

[jdhfch]

Hi,

Please can anyone help me with some VBA code.

I am wanting to consolidate all files into a folder into one master file. The files are all the same format and all have 3 worksheets named, Price, Cost & Volume. The data goes from column a - x. There are a lot of files, and there is a new file added every day.

I can find loads that work for one worksheet, but none for multiple worksheets across multiple files.

 

[GerrardSVK]

Something like this may be helpfull but there is inportant order of openning files.

Workbooks(1).Sheets(1).Range("Your Range For example: A1:B9").Copy
Workbooks(2).Sheets(1).Range("Your Range For example: A1:B9").PasteSpecial xlPasteValues
Workbooks(1).Sheets(1).Range("Your Range For example: A1:B9").Copy
Workbooks(3).Sheets(1).Range("Your Range For example: A1:B9").PasteSpecial xlPasteValues
Workbooks(1).Sheets(1).Range("Your Range For example: A1:B9").Copy
Workbooks(4).Sheets(1).Range("Your Range For example: A1:B9").PasteSpecial xlPasteValues

 

[MikeVol]

Hello @jdhfch.
Try next code:

Option Explicit

Sub MergeFilesToMaster()
    Dim wbSource As Workbook, wsSource As Worksheet
    Dim DataRange As Range, Arr As Variant
    Dim LastRow As Long, PasteRow As Long
    Dim i           As Long

    Dim FolderPath  As String
    FolderPath = "D:\New Folder\"    ' Replace with your path

    Dim MasterFile  As Workbook
    Set MasterFile = ThisWorkbook

    Dim wsNames     As Variant
    wsNames = Array("Price", "Cost", "Volume")

    Dim FileName    As String
    FileName = Dir(FolderPath & "*.xls*")

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False

        Do While FileName <> ""
            Set wbSource = Workbooks.Open(FolderPath & FileName, ReadOnly:=True)

            For i = LBound(wsNames) To UBound(wsNames)
                On Error Resume Next
                Set wsSource = wbSource.Sheets(wsNames(i))
                On Error GoTo 0

                If Not wsSource Is Nothing Then
                    LastRow = wsSource.Cells(Rows.Count, "A").End(xlUp).Row

                    If LastRow >= 2 Then   ' It is assumed that the first row contains headings (if there is something to copy)
                        Set DataRange = wsSource.Range("A2:X" & LastRow)
                        Arr = DataRange.Value

                        With MasterFile.Sheets(wsNames(i))
                            PasteRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                            .Cells(PasteRow, 1).Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
                        End With

                    End If

                End If

            Next i

            wbSource.Close False
            FileName = Dir
        Loop

        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

    MsgBox "Merging files into one Master File is complete.!", vbInformation
End Sub

Read the comments in the code and make the necessary changes according to the comments and everything will work correctly for you. I hope I was able to help you. Good luck.

 

[jdhfch]

Hello @jdhfch.
Try next code:

Option Explicit

Sub MergeFilesToMaster()
    Dim wbSource As Workbook, wsSource As Worksheet
    Dim DataRange As Range, Arr As Variant
    Dim LastRow As Long, PasteRow As Long
    Dim i           As Long

    Dim FolderPath  As String
    FolderPath = "D:\New Folder\"    ' Replace with your path

    Dim MasterFile  As Workbook
    Set MasterFile = ThisWorkbook

    Dim wsNames     As Variant
    wsNames = Array("Price", "Cost", "Volume")

    Dim FileName    As String
    FileName = Dir(FolderPath & "*.xls*")

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False

        Do While FileName <> ""
            Set wbSource = Workbooks.Open(FolderPath & FileName, ReadOnly:=True)

            For i = LBound(wsNames) To UBound(wsNames)
                On Error Resume Next
                Set wsSource = wbSource.Sheets(wsNames(i))
                On Error GoTo 0

                If Not wsSource Is Nothing Then
                    LastRow = wsSource.Cells(Rows.Count, "A").End(xlUp).Row

                    If LastRow >= 2 Then   ' It is assumed that the first row contains headings (if there is something to copy)
                        Set DataRange = wsSource.Range("A2:X" & LastRow)
                        Arr = DataRange.Value

                        With MasterFile.Sheets(wsNames(i))
                            PasteRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                            .Cells(PasteRow, 1).Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
                        End With

                    End If

                End If

            Next i

            wbSource.Close False
            FileName = Dir
        Loop

        .DisplayAlerts = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

    MsgBox "Merging files into one Master File is complete.!", vbInformation
End Sub

Read the comments in the code and make the necessary changes according to the comments and everything will work correctly for you. I hope I was able to help you. Good luck.

Excellent, thank you