Merge Functions‎ > ‎

WBs to Sheets

  
There are 4 macros on this page:

  1. Appending Data to Existing Sheets and creating new sheets from a "template" if necessary
  2. Open all files and simply copy sheet as a whole
  3. All Subfolders in a main folder
  4. Append Data in All Sheets in all workbooks into matching sheetnames in a Master workbook


PART 1 - Appending Data to Existing Sheets and
                creating new sheets from a "template" if necessary


SPECIFICATIONS:

  1. Open all the files in a single folder, each wb has a single sheet
     
  2. Copy data from each workbook into a Master workbook, adding the data to sheet of the same name as the workbook(s)
  3. If a workbook is opened that does not have an existing sheet in the Master workbook, copy a "template sheet" and set it up to receive new data. The headers in row 1 from the template sheet are all that are retained.
  4. After importation, workbooks are moved to preclude accidental reimportation
  5. Sections of code to edit are highlighted

CODE

Sub ConsolidateWBsToSheets()
'Author:     Jerry Beaucaire'
'Date:       9/15/2009     (2007 compatible)
'Updated:    5/16/2010
'Summary:    Open all Excel files in a specific folder and merge data
'            into master sheets named for file names(stacked)
'            create new sheets as needed
'            Move imported files into another folder
Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long, shtAdd As String, ShtName As Worksheet
Dim wbData As Workbook, wbkNew As Workbook

'Setup
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
  
    Set wbkNew = ThisWorkbook
    wbkNew.Activate
  
'Path and filename (edit this section to suit)
    fPath = "C:\2010\"                  'remember final \ in this string
    fPathDone = fPath & "Imported\"     'remember final \ in this string
    On Error Resume Next
        MkDir fPathDone                 'creates the completed folder if missing
    On Error GoTo 0
    fName = Dir(fPath & "*.xls")        'listing of desired files, edit filter as desired

'Import data from each found file
    Do While Len(fName) > 0
    'make sure THIS file isn't accidentally reopened
        If fName <> wbkNew.Name Then
        'check if sheet to append to already exists, create if needed
                ShtAdd = Left(Left(fName, InStrRev(fName, ".") - 1), 29)
            If Not Evaluate("ISREF('" & shtAdd & "'!A1)") Then
                Sheets("Report001").Copy After:=Sheets(Sheets.Count)
                ActiveSheet.Name = shtAdd
                Range("A2:A" & Rows.Count).EntireRow.Clear
            End If
            Set ShtName = ThisWorkbook.Sheets(shtAdd)
       
        'Open file
            Set wbData = Workbooks.Open(fPath & fName)

        'This is the section to customize, replace with your own action code as needed
        'Find last row and copy data
            LR = Cells.Find("*", Cells(Rows.Count, Columns.Count), _
                SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            Range("A2:A" & LR).EntireRow.Copy _
                ShtName.Range("C" & Rows.Count).End(xlUp).Offset(1, 0)
           
        'close file
            wbData.Close False
        'move file to IMPORTED folder
            Name fPath & fName As fPathDone & fName
        'ready next filename, reassert the list since a file was moved
            fName = Dir(fPath & "*.xls")
        End If
    Loop

ErrorExit:    'Cleanup
    Application.DisplayAlerts = True         'turn system alerts back on
    Application.EnableEvents = True          'turn other macros back on
    Application.ScreenUpdating = True        'refreshes the screen
End Sub


PART 2 - Open all files and simply copy sheet as a whole

SPECIFICATIONS:

  1. Open all the files in a single folder, each wb has a single sheet
  2. Copy sheet from each workbook into a Master workbook
  3. Rename the copied sheet with the name of the source workbook
  4. After importation, source workbooks are moved to preclude accidental reimportation
  5. Sections of code to edit are highlighted

CODE

Option Explicit

Sub ConsolidateWBsToSheets2()
'Author:     Jerry Beaucaire'
'Date:       6/23/2010     (2007 compatible)
'Summary:    Open all Excel files in a specific folder and copy
'            one sheet from the source files into this master workbook
'            naming sheets for the names of the source workbooks
'            Move imported files into another folder
Dim fName As String, fPath As String, fPathDone As String
Dim LR As Long, NR As Long, shtAdd As String, ShtName As Worksheet
Dim wbData As Workbook, wbkNew As Workbook

'Setup
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
 
    Set wbkNew = ThisWorkbook
    wbkNew.Activate
 
'Path and filename (edit this section to suit)
    fPath = "C:\2010\"                  'remember final \ in this string
    fPathDone = fPath & "Imported\"     'remember final \ in this string
    On Error Resume Next
        MkDir fPathDone                 'creates the completed folder if missing
    On Error GoTo 0
    fName = Dir(fPath & "*.xls")                'listing of desired files, edit filter as desired

'Import data from each found file
    Do While Len(fName) > 0
    'make sure THIS file isn't accidentally reopened
        If fName <> wbkNew.Name Then
        
        'This is the section to customize, what to copy and to where
        'Get name of workbook without extension
            shtAdd = Left(Left(fName, InStr(fName, ".") - 1), 29)
        'Open file
            Set wbData = Workbooks.Open(fPath & fName)
            
        'Rename sheet and copy to target workbook
            wbData.Sheets(1).Name = shtAdd
            wbData.Sheets(1).Copy After:=wbkNew.Sheets(wbkNew.Sheets.Count)

           
        'close source file
            wbData.Close False
        'move file to IMPORTED folder
            Name fPath & fName As fPathDone & fName
        'ready next filename, reassert the list since a file was moved
            fName = Dir(fPath & "*.xls")
        End If
    Loop

ErrorExit:    'Cleanup
    Application.DisplayAlerts = True         'turn system alerts back on
    Application.EnableEvents = True          'turn other macros back on
    Application.ScreenUpdating = True        'refreshes the screen
End Sub


PART 3 - All Subfolders in a main folder

SPECIFICATIONS:
  1. Macro specifies the main folder
  2. Go into all subfolders in this main folder and process a specific file in all of these subfolders (extract.xls)
  3. Each file opened has multiple sheets, import the data from each sheet starting at row7 and bring into the main sheet into a sheet named for the same as the source sheet
  4. Create the destination sheet in the destination workbook if needed
  5. Sections of code to edit are highlighted

CODE

Option Explicit

Sub ImportSameFileNameDataAllSubFolders()
'Author:    Jerry Beaucaire
'Date:      8/9/2010
'Summary:   Opens the same filename in all subfolders
'           imports data from row 7 down into this workbook
'           putting data into sheets with same names as imported data
'           Destination book creates blank sheets if necessary

Dim fNAME As String:    fNAME = "extract.xls"
Dim fPATH As String:    fPATH = "C:\2010\Test\Main\"    'don't forget the final \ in this string
Dim FSO As Object:      Set FSO = CreateObject("Scripting.FileSystemObject")
Dim FLD As Object:      Set FLD = FSO.GetFolder(fPATH)
Dim SubFLDRS As Object: Set SubFLDRS = FLD.SubFolders
Dim SubFLD As Object
Dim wbMain As Workbook: Set wbMain = ThisWorkbook
Dim wbData As Workbook
Dim ws As Worksheet
Dim LR As Long
Dim wsTest As String

Application.ScreenUpdating = False

For Each SubFLD In SubFLDRS
    Set wbData = Workbooks.Open(fPATH & SubFLD.Name & "\" & fNAME)
   
    On Error Resume Next   'This allows the add-sheet stuff to work if sheet is missing
   
    For Each ws In ActiveWorkbook.Worksheets
        LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
        ws.Range("A7:A" & LR).EntireRow.Copy
        With wbMain     'add sheet if needed
            If Not Evaluate("ISREF('[" & wbMain.Name & "]" & ws.Name & "'!$A$1)") Then _
                .Worksheets.Add(After:=.Worksheets(.Worksheets.Count)).Name = ws.Name
            .Sheets(ws.Name).Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        End With
    Next ws
   
    Application.CutCopyMode = False
    wbData.Close False
Next SubFLD

Set wbMain = Nothing
Application.ScreenUpdating = True
End Sub



PART 4 - Appending Data from All Existing Sheets in all workbooks into
                a Master Workbook matching the sheetnames


SPECIFICATIONS:

  1. Open all the files in a single folder, each wb has a multiple sheets
  2. Copy data from each worksheet into the Master workbook, adding the data to sheet of the same name as the workbook(s)
  3. It is presumed the matching sheets already exist in the main workbook
  4. Sections of code to edit are highlighted

CODE

Option Explicit

Sub ConsolidateSheetsFromWorkbooks()
'Author:    Jerry Beaucaire, ExcelForum.com
'Date:      1/5/2011, 10/20/2014
'Summary:   Open all files in a folder and merge data (stacked) on all sheets into main wb matching the sheet names.
'           Assumes all sheets with titles exist in main book and data sheets data starts at row 2
'           If matching sheetname is not found in the master workbook, it is skipped
Dim wbData As Workbook, wbMain As Workbook, wsMain As Worksheet, wsData As Worksheet
Dim LR As Long, NR As Long, fPath As String, fName As String

Set wbMain = ThisWorkbook           'keeps destination focus on this workbook
                                    'if files are stored in separate directory edit fPath
fPath = ThisWorkbook.Path & "\"     'don't forget the final \
                                   
fName = Dir(fPath & "*.xls")        'start looping through files one at a time
Application.ScreenUpdating = False  'speed up macro
On Error Resume Next                'allow macro to proceed if sheetname matches are missing

Do While Len(fName) > 0             'process one workbook at a time
    If fName <> ThisWorkbook.Name Then
        Set wbData = Workbooks.Open(fPath & fName)      'open the next resource workbook
        For Each wsData In wbData.Worksheets            'cycle through the sheets
            Set wsMain = wbMain.Sheets(wsData.Name)     'try to match the sheetnames
            If Not wsMain Is Nothing Then               'only proceed if a matching sheetname was found
                NR = wsMain.Range("A" & Rows.Count).End(xlUp).Row + 1   'next empty row
                With wsData                             'measure the used rows then copy
                    LR = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Range("A2:A" & LR).EntireRow.Copy wsMain.Range("A" & NR)
                End With
                Set wsMain = Nothing
            End If
        Next wsData
       
        wbData.Close False
    End If
   
    fName = Dir                 'queue up next filename
Loop

Application.ScreenUpdating = True      'update screen, back to normal
End Sub


Nothing says "thanks" like a steak dinner!
PayPal - The safer, easier way to pay online!
Comments