Results 1 to 5 of 5

Thread: Consolidating multiple separate workbooks into one "Consolidated Workbook"

  1. #1
    Acolyte Adnandos's Avatar
    Join Date
    Jun 2018
    Excel Version

    Consolidating multiple separate workbooks into one "Consolidated Workbook"

    Register for a FREE account, and/
    or Log in to avoid these ads!

    Hi all -not sure exactly where to post this.

    I have 20 workbooks that is prepared by 20 different users monthly.

    In each workbook there are 5 worksheet tabs, each "clean" workbook is identical in every sense, layout, structure etc.

    Meaning worksheet 3 in workbook 1 is identical to worksheet 3 in workbook 2 etc. The users capture data into each worksheet into the respective columns.

    At the end of each month I literally open a "clean consolidated" workbook, and begin opening each worksheet in each completed workbook and manually copy it into the consolidated workbook.

    There must be a faster way of doing this (macro, vba, something else?) if the relevant workbooks are all stored in the same folder?

    If there is, please share how this could be done.

    Would really appreciate any assistance, and like I said, not sure where this should have been posted.

  2. #2
    Conjurer Ed Kelly's Avatar
    Join Date
    Jul 2016
    Excel Version
    Yes you need to use Get data in Excel and import a folder containing all 20 workbooks and then append each 20 sheet 1's, sheet 2's...

    Consider sending 3 workbooks with fictitious data 3-5 lines in each tab of each workbook and I will do it for you then all you need do is connect it to your real data and refresh it. Need to see the exact structure in case any kinks need to be handled.

    Knock 'em dead Sailor!

  3. #3
    Conjurer Logit's Avatar
    Join Date
    Nov 2016
    Excel Version
    Paste this into a Routine Module :

    Option Explicit
     '32-bit API declarations
    Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _
    pszpath As String) As Long
    Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) _
    As Long
    Public Type BrowseInfo
        hOwner As Long
        pIDLRoot As Long
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As Long
        lParam As Long
        iImage As Long
    End Type
    Function GetDirectory(Optional msg) As String
        On Error Resume Next
        Dim bInfo As BrowseInfo
        Dim path As String
        Dim r As Long, x As Long, pos As Integer
         'Root folder = Desktop
        bInfo.pIDLRoot = 0&
         'Title in the dialog
        If IsMissing(msg) Then
            bInfo.lpszTitle = "Please select the folder of the excel files to copy."
            bInfo.lpszTitle = msg
        End If
         'Type of directory to return
        bInfo.ulFlags = &H1
         'Display the dialog
        x = SHBrowseForFolder(bInfo)
         'Parse the result
        path = Space$(512)
        r = SHGetPathFromIDList(ByVal x, ByVal path)
        If r Then
            pos = InStr(path, Chr$(0))
            GetDirectory = Left(path, pos - 1)
            GetDirectory = ""
        End If
    End Function
    Sub CombineFiles()
        Dim path            As String
        Dim FileName        As String
        Dim LastCell        As Range
        Dim Wkb             As Workbook
        Dim WS              As Worksheet
        Dim ThisWB          As String
        Dim pasteSht        As Worksheet
        ThisWB = ThisWorkbook.Name
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        path = GetDirectory
        FileName = Dir(path & "\*.xls*", vbNormal)
        Set pasteSht = Worksheets("Sheet1")
        Do Until FileName = ""
            If FileName <> ThisWB Then
                Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName)
                For Each WS In Wkb.Worksheets
                    Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
                    If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
                        WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                    End If
                Next WS
                Wkb.Close False
            End If
            FileName = Dir()
        Application.EnableEvents = True
        Application.ScreenUpdating = True
        Set Wkb = Nothing
        Set LastCell = Nothing
    End Sub
    See attached
    Attached Files Attached Files

  4. #4
    Administrator Pecoflyer's Avatar
    Join Date
    Oct 2011
    Brussels Belgium
    Excel Version
    2010 on Xubuntu
    Thank you Ken for this secure forum.

  5. #5
    Acolyte Adnandos's Avatar
    Join Date
    Jun 2018
    Excel Version
    Apologies for the late response, this ended up being the type of solution that worked. Get data, append and working with queries made my life much easier!

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts