Solved

An easy way to combine spreadsheets

Posted on 2011-03-21
28
282 Views
Last Modified: 2012-05-11
I have about 35 spreadsheets that I need to combine into one.  They all have the same layout exactly, so I was wondering if there was a way to combine them automatically using VBA.  I thought, at the very least, if I opened them all at once, I could use the open workbooks collection.  Any ideas or thoughts?
0
Comment
Question by:BBlu
  • 15
  • 13
28 Comments
 
LVL 39

Expert Comment

by:nutsch
ID: 35185165
Great article from Dave, with working code can be found at this link.

The full code, straight from this article is below. Explanations can be found in the article but I'll be happy to guide you if you need.

Public Sub ConsolidateSheets()
    Dim Wb1 As Workbook
    Dim Wb2 As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim rngArea As Range
    Dim lrowSpace As Long
    Dim lSht As Long
    Dim lngCalc As Long
    Dim lngRow As Long
    Dim lngCol As Long
    Dim X()
    Dim bProcessFolder As Boolean
    Dim bNewSheet As Boolean

    Dim StrPrefix
    Dim strFileName As String
    Dim strFolderName As String

    'variant declaration needed for the Shell object to use a default directory
    Dim strDefaultFolder As Variant


 bProcessFolder = (MsgBox("Process a single folder (Yes)," & vbNewLine & "or single file (No)", vbYesNo, "Application Scope: Folder or single File") = vbYes)
    bNewSheet = (MsgBox("Extract all data to a single sheet (TRUE)," & vbNewLine & "or a target file sheet for each source sheet(FALSE)", vbYesNo, "Output Format: Single sheet or sheet by sheet collection") = vbYes)
    If Not bProcessFolder Then
        If Not bNewSheet Then
            MsgBox "There isn't much point creating a exact replica of your source file :)"
            Exit Sub
        End If
    End If

    'set default directory here if needed
    strDefaultFolder = "C:\temp"

    'If the user is collating all the sheets to a single target sheet then the row spacing
    'to distinguish between different sheets can be set here
    lrowSpace = 1

    If bProcessFolder Then
        strFolderName = BrowseForFolder(strDefaultFolder)
        'Look for xls, xlsx, xlsm files
        strFileName = Dir(strFolderName & "\*.xls*")
    Else
        strFileName = Application _
                      .GetOpenFilename("Select file to process (*.xls), *.xls")
    End If

    Set Wb1 = Workbooks.Add(1)
    Set ws1 = Wb1.Sheets(1)
    If Not bNewSheet Then ws1.Range("A1:B1") = Array("workbook name", "worksheet count")

    'Turn off screenupdating, events, alerts and set calculation to manual
    With Application
        .DisplayAlerts = False
        .EnableEvents = False
        .ScreenUpdating = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End With

    'set path outside the loop
    StrPrefix = strFolderName & IIf(bProcessFolder, "\", vbNullString)

    Do While Len(strFileName) > 0
        'Provide progress status to user
        Application.StatusBar = Left("Processing " & strFolderName & "\" & strFileName, 255)
        'Open each workbook in the folder of interest
        Set Wb2 = Workbooks.Open(StrPrefix & strFileName)
        If Not bNewSheet Then
            'add summary details to first sheet
            ws1.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = Wb2.Name
            ws1.Cells(Rows.Count, "A").End(xlUp).Offset(0, 1) = Wb2.Sheets.Count
        End If
        For Each ws2 In Wb2.Sheets
            If bNewSheet Then
                'All data to a single sheet
                'Skip importing target sheet data if the source sheet is blank
                Set rng2 = ws2.Cells.Find("*", ws2.[a1], xlValues, , xlByRows, xlPrevious)

                If Not rng2 Is Nothing Then
                    Set rng1 = ws1.Cells.Find("*", ws1.[a1], xlValues, , xlByRows, xlPrevious)
                    'Find the first blank row on the target sheet
                    If Not rng1 Is Nothing Then
                        Set rng3 = ws2.Range(ws2.UsedRange.Cells(1), ws2.Cells(rng2.Row, "A"))
                        'Ensure that the row area in the target sheet won't be exceeded
                        If rng3.Rows.Count + rng1.Row < Rows.Count Then
                            'Copy the data from the used range of each source sheet to the first blank row
                            'of the target sheet, using the starting column address from the source sheet being copied
                            ws2.UsedRange.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)
                        Else
                            MsgBox "Summary sheet size exceeded. Process stopped on " & vbNewLine & _
                                   "sheet: " & ws2.Name & vbNewLine & "of" & vbNewLine & "workbook: " & Wb2.Name
                            Wb2.Close False
                            Exit Do
                        End If
                        'colour the first of any spacer rows
                        If lrowSpace <> 0 Then ws1.Rows(rng1.Row + 1).Interior.Color = vbGreen
                    Else
                        'target sheet is empty so copy to first row
                        ws2.UsedRange.Copy ws1.Cells(1, ws2.UsedRange.Cells(1).Column)
                    End If
                End If
            Else
                'new target sheet for each source sheet
                ws2.Copy after:=Wb1.Sheets(Wb1.Sheets.Count)
                'Remove any links in our target sheet
                With Wb1.Sheets(Wb1.Sheets.Count).Cells
                    .Copy
                    .PasteSpecial xlPasteValues
                End With
                On Error Resume Next
                Wb1.Sheets(Wb1.Sheets.Count).Name = ws2.Name
                'sheet name already exists in target workbook
                If Err.Number <> 0 Then
                    'Add a number to the sheet name till a unique name is derived
                    Do
                        lSht = lSht + 1
                        Set ws3 = Wb1.Sheets(ws2.Name & " " & lSht)
                    Loop While Not ws3 Is Nothing
                    lSht = 0
                End If
                On Error GoTo 0
            End If
        Next ws2
        'Close the opened workbook
        Wb2.Close False
        'Check whether to force a DO loop exit if processing a single file
        If bProcessFolder = False Then Exit Do
        strFileName = Dir
    Loop

    'Remove any links if the user has used a target sheet
    If bNewSheet Then
        With ws1.UsedRange
            .Copy
            .Cells(1).PasteSpecial xlPasteValues
            .Cells(1).Activate
        End With
    Else
        'Format the summary sheet if the user has created separate target sheets
        ws1.Activate
        ws1.Range("A1:B1").Font.Bold = True
        ws1.Columns.AutoFit
    End If

    With Application
        .CutCopyMode = False
        .DisplayAlerts = True
        .EnableEvents = True
        .ScreenUpdating = True
        .Calculation = lngCalc
        .StatusBar = vbNullString
    End With
End Sub


Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'From Ken Puls as used in his vbaexpress.com article
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284

    Dim ShellApp As Object
    'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
                   BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

    'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0

    'Destroy the Shell Application
    Set ShellApp = Nothing

    'Check for invalid or non-entries and send to the Invalid error
    'handler if found
    'Valid selections can begin L: (where L is a letter) or
    '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select

    Exit Function

Invalid:
    'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
End Function

Open in new window


Thomas
0
 

Author Comment

by:BBlu
ID: 35185184
Can the code be simplified if each workbook only has one sheet- called "main"?
0
 
LVL 39

Expert Comment

by:nutsch
ID: 35185186
My version of this code, simpler but less flexible, working on the open workbook can be found below: just copy in a module and run


Sub consolidateSheets()
Dim shtDone As Worksheet, lstRow As Long
Dim wksht As Worksheet, firstSheet As Boolean

Const bolTitles As Boolean = True 'True if sheets have titles, false if they don't
Const strSummary As String = "All" ' update to the name of the consolidated destination
Const bolTab As Boolean = True 'get data from tab name ? True / False
Const strTabTitle As String = "Type" 'title of column from tab name if bolTab=true
Dim lgTabCol As Long

Call TurnOffAllUpdates(True)

Set shtDone = Sheets.Add

On Error Resume Next
shtDone.Name = strSummary

If Err.Number <> 0 Then
    ActiveWorkbook.Sheets(strSummary).Delete
    shtDone.Name = strSummary
    Err.Clear
End If

firstSheet = True

For Each wksht In ActiveWorkbook.Sheets
    
    If wksht.Name = strSummary Then GoTo nxtSht
    
    wksht.[a1].CurrentRegion.Copy
    
    lstRow = shtDone.range("A" & Rows.Count).End(xlUp).Row
    
    shtDone.Select
    shtDone.range("A" & lstRow + 1).Select
    ActiveSheet.Paste

    If bolTitles = True And firstSheet = False Then
        Rows(lstRow + 1).Delete
    Else
        If bolTab = True And firstSheet = True Then
            lgTabCol = shtDone.Cells(2, Columns.Count).End(xlToLeft).Column + 1
            shtDone.Cells(2, lgTabCol) = strTabTitle
            lstRow = lstRow + 1
        End If
    End If
    
    If bolTab = True Then
        shtDone.Cells(lstRow + 1, lgTabCol) = wksht.Name
    End If
        
    firstSheet = False

nxtSht:
Next

If bolTab = True Then
    Intersect(ActiveSheet.UsedRange, Columns(lgTabCol)).Offset(1, 0).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    Columns(lgTabCol).Copy
    ActiveSheet.PasteSpecial Paste:=xlPasteValues
    application.CutCopyMode = False
End If

Call TurnOffAllUpdates(False)
End Sub

Open in new window

0
 
LVL 39

Expert Comment

by:nutsch
ID: 35185199
Here is a code that will combine all Main sheets from all workbooks in a folder. Update the line
Const strPath As String = "C:\temp"
to your desired folder.

Thomas
Sub ConsolidateFiles()
'REQUIREMENTS:
'    - Function GetSubFolders

'Creates a new workbook with path to all files in folder and subfolders
'Consolidate the first sheet of all the workbooks in the folder and its subfolders

application.ScreenUpdating = False 'disable screen updating to avoid screen flashing
Dim FileName As String, intFileCount As Long, strFullPath As String
Const strPath As String = "C:\temp" 'update to your file path
Dim myArr, i As Long
Dim wbk1 As Workbook, wbk2 As Workbook

myArr = GetSubFolders(strPath)
Set wbk1 = Workbooks.Add

For i = LBound(myArr) To UBound(myArr)

    FileName = Dir(strPath & "\" & myArr(i) & "\*.xls")
    Do While FileName <> ""
       intFileCount = intFileCount + 1
       
       strFullPath = strPath & "\" & myArr(i) & "\" & FileName
       
'**************************LIST FILES******************************
       wbk1.Sheets(1).Cells(intFileCount, 1) = strFullPath
       wbk1.Sheets(1).Cells(intFileCount, 2) = FileName
'******************************************************************

'***********************CONSOLIDATE FILES**************************
    Set wbk2 = Workbooks.Open(strFullPath)
    On Error Resume Next
    wbk2.Sheets("Main").Copy After:=wbk1.Sheets(1)
    wbk2.Close False

    If Err.Number = 0 Then
        wbk1.ActiveSheet.Name = Left(FileName, InStr(FileName, ",") + 2) 'wbk2.name
    Else
        wbk1.Sheets(1).Cells(intFileCount, 3) = "Error"
        Err.Clear
    End If

    Set wbk2 = Nothing
'******************************************************************

       FileName = Dir
    Loop

Next

application.ScreenUpdating = True

End Sub


Function GetSubFolders(RootPath As String)
'function plundered from Patrick Matthews, EE comment 19880728
    Dim arr() As String
    Dim FSO As Object
    Dim fld As Object
    Dim sf As Object
    Dim Counter As Long
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fld = FSO.GetFolder(RootPath)
    ReDim arr(1 To fld.SubFolders.Count) As String
    For Each sf In fld.SubFolders
        Counter = Counter + 1
        arr(Counter) = sf.Name
    Next

    GetSubFolders = arr

    Set sf = Nothing: Set fld = Nothing: Set FSO = Nothing

End Function

Open in new window

0
 

Author Comment

by:BBlu
ID: 35185220
So I just create this in a standard module in a new workbook.  Then open the workbook and run?
0
 
LVL 39

Expert Comment

by:nutsch
ID: 35185236
Pretty much, or you can copy it in a personal.xls as it creates a new workbook anyway. For information about personal.xls use, check the help below from Brad Yundt:

'The best place to store macros you'll be using all the time is in your Personal.xls workbook. This workbook is always opened when Excel launches, but remains invisible (though you can see it from the VBA Editor). If you don't have one, the easiest way to create it is to record a macro:
'1) Start the macro recorder using the Tools...Macro...Record New Macro menu item
'2) In the resulting dialog, go to the "Store macro in" field, and choose "Personal macro workbook"
'3) Click "OK"
'4) Click the "End macro" button on the macro toolbar. You don't need this macro to do anything other than create a copy of Personal.xls
'5) ALT + F11 to open the VBA Editor, then paste your macros in a module sheet in Personal.xls
'6) Use the File...Save button to save Personal.xls after the changes
'
'In Excel 2003 and earlier, you can add a button on a toolbar for your macro as follows:
'1) Open the View...Toolbars...Customize menu item
'2) Go to the Commands tab
'3) Choose Macros in the toolbar selector on the left
'4) Choose a smiley-face button on the right, then drag it up to the toolbar
'5) Right-click the new button, then choose "Assign Macro" from the resulting pop-up. Pick the macro you want to link the button to in the next dialog, then click "OK"
'6) If you want to choose a different button image, right-click the button one more time, then choose "Change Button Image". You can now pick from 42 different icons. If those choices don't satisfy your inner artist, choose "Edit Button Image" and then edit the 16x16 pixel grid to your heart's content. Note: if you get the Toolbar selection menu rather than the button context sensitive menu, just choose "Customize" and then right-click the button a second time.
'
'
'In Excel 2007 and later, you can add a button to the Quick Access Toolbar to call your macro. To do so:
'1) Right-click the Quick Access Toolbar and choose Customize Quick Access Toolbar... from the resulting dialog
'2) In the "Choose commands from" field at the top, choose Macros
'3) Select your macro in the left pane of the resulting dialog, then click the Add button between  the two panes
'4) Click the Modify button at the bottom of the right pane. You will be greeted with a window containing 181 icons to pick from.
0
 

Author Comment

by:BBlu
ID: 35185280
i get run-time error '9'
"subscript out of range" on
 ReDim arr(1 To fld.SubFolders.Count) As String
0
 
LVL 39

Expert Comment

by:nutsch
ID: 35185317
Here is an update that should improve it


Sub ConsolidateFiles()
'REQUIREMENTS:
'    - Function GetSubFolders

'Creates a new workbook with path to all files in folder and subfolders
'Consolidate the first sheet of all the workbooks in the folder and its subfolders

application.ScreenUpdating = False 'disable screen updating to avoid screen flashing
Dim FileName As String, intFileCount As Long, strFullPath As String
Const strPath As String = "C:\TEMP\SplitFiles" 'update to your file path
Dim myArr, i As Long
Dim wbk1 As Workbook, wbk2 As Workbook

'myArr = GetSubFolders(strPath)
Set wbk1 = Workbooks.Add


'For i = LBound(myArr) To UBound(myArr)

    FileName = Dir(strPath & "\*.xls") '"\" & myArr(i) & "\*.xls")
    Do While FileName <> ""
       intFileCount = intFileCount + 1
       
       strFullPath = strPath & "\" & FileName '"\" & myArr(i) & "\" & FileName
       
'**************************LIST FILES******************************
'       wbk1.Sheets(1).Cells(intFileCount, 1) = strFullPath
'      wbk1.Sheets(1).Cells(intFileCount, 2) = FileName
'******************************************************************

'***********************CONSOLIDATE FILES**************************
    Set wbk2 = Workbooks.Open(strFullPath)
    On Error Resume Next
    wbk2.Sheets(1).Copy After:=wbk1.Sheets(1)
    wbk2.Close False

    If Err.Number = 0 Then
        wbk1.ActiveSheet.Name = Left(FileName, InStr(FileName, ",") + 2) 'wbk2.name
    Else
        wbk1.Sheets(1).Cells(intFileCount, 3) = "Error"
        Err.Clear
    End If

    Set wbk2 = Nothing
'******************************************************************

       FileName = Dir
    Loop

'Next

call consolidatesheets

application.ScreenUpdating = True

Private Sub consolidateSheets()
Dim shtDone As Worksheet, lstRow As Long
Dim wksht As Worksheet, firstSheet As Boolean

'requires TurnOffAllUpdates macro

Const bolTitles As Boolean = True 'True if sheets have titles, false if they don't
Const strSummary As String = "All" ' update to the name of the consolidated destination
Const bolTab As Boolean = True 'get data from tab name ? True / False
Const strTabTitle As String = "Type" 'title of column from tab name if bolTab=true
Dim lgTabCol As Long

Call TurnOffAllUpdates(True)

Set shtDone = Sheets.Add

On Error Resume Next
shtDone.Name = strSummary

If Err.Number <> 0 Then
    ActiveWorkbook.Sheets(strSummary).Delete
    shtDone.Name = strSummary
    Err.Clear
End If

firstSheet = True

For Each wksht In ActiveWorkbook.Sheets
    
    If wksht.Name = strSummary Then GoTo nxtSht
    
    lstRow = shtDone.Cells(Rows.Count, 1).End(xlUp).Row
    wksht.[a1].CurrentRegion.Copy shtDone.Cells(lstRow + 1, 1).Select

    If bolTitles = True And firstSheet = False Then
        Rows(lstRow + 1).Delete
    Else
        If bolTab = True And firstSheet = True Then
            lgTabCol = shtDone.Cells(2, Columns.Count).End(xlToLeft).Column + 1
            shtDone.Cells(2, lgTabCol) = strTabTitle
            lstRow = lstRow + 1
        End If
    End If
    
    If bolTab = True Then
        shtDone.Cells(lstRow + 1, lgTabCol) = wksht.Name
    End If
        
    firstSheet = False

nxtSht:
Next

If bolTab = True Then
    Intersect(ActiveSheet.UsedRange, Columns(lgTabCol)).Offset(1, 0).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    Columns(lgTabCol).Copy
    ActiveSheet.PasteSpecial Paste:=xlPasteValues
    application.CutCopyMode = False
End If

Call TurnOffAllUpdates(False)
End Sub

End Sub

private Sub TurnOffAllUpdates(blSwitchOff As Boolean)

If blSwitchOff Then
    application.ScreenUpdating = False
    application.Calculation = xlCalculationManual
Else
    application.ScreenUpdating = True
    application.Calculation = xlCalculationAutomatic
End If

End Sub

Open in new window

0
 

Author Comment

by:BBlu
ID: 35185335

I got an "expected end sub"
right before this...

Private Sub consolidateSheets()

Should I just add the 'end sub'?
0
 
LVL 39

Expert Comment

by:nutsch
ID: 35185354
one to add, one to remove
Sub ConsolidateFiles()
'REQUIREMENTS:
'    - Function GetSubFolders

'Creates a new workbook with path to all files in folder and subfolders
'Consolidate the first sheet of all the workbooks in the folder and its subfolders

application.ScreenUpdating = False 'disable screen updating to avoid screen flashing
Dim FileName As String, intFileCount As Long, strFullPath As String
Const strPath As String = "C:\TEMP\SplitFiles" 'update to your file path
Dim myArr, i As Long
Dim wbk1 As Workbook, wbk2 As Workbook

'myArr = GetSubFolders(strPath)
Set wbk1 = Workbooks.Add


'For i = LBound(myArr) To UBound(myArr)

    FileName = Dir(strPath & "\*.xls") '"\" & myArr(i) & "\*.xls")
    Do While FileName <> ""
       intFileCount = intFileCount + 1
       
       strFullPath = strPath & "\" & FileName '"\" & myArr(i) & "\" & FileName
       
'**************************LIST FILES******************************
'       wbk1.Sheets(1).Cells(intFileCount, 1) = strFullPath
'      wbk1.Sheets(1).Cells(intFileCount, 2) = FileName
'******************************************************************

'***********************CONSOLIDATE FILES**************************
    Set wbk2 = Workbooks.Open(strFullPath)
    On Error Resume Next
    wbk2.Sheets(1).Copy After:=wbk1.Sheets(1)
    wbk2.Close False

    If Err.Number = 0 Then
        wbk1.ActiveSheet.Name = Left(FileName, InStr(FileName, ",") + 2) 'wbk2.name
    Else
        wbk1.Sheets(1).Cells(intFileCount, 3) = "Error"
        Err.Clear
    End If

    Set wbk2 = Nothing
'******************************************************************

       FileName = Dir
    Loop

'Next
End Sub

call consolidatesheets

application.ScreenUpdating = True

Private Sub consolidateSheets()
Dim shtDone As Worksheet, lstRow As Long
Dim wksht As Worksheet, firstSheet As Boolean

'requires TurnOffAllUpdates macro

Const bolTitles As Boolean = True 'True if sheets have titles, false if they don't
Const strSummary As String = "All" ' update to the name of the consolidated destination
Const bolTab As Boolean = True 'get data from tab name ? True / False
Const strTabTitle As String = "Type" 'title of column from tab name if bolTab=true
Dim lgTabCol As Long

Call TurnOffAllUpdates(True)

Set shtDone = Sheets.Add

On Error Resume Next
shtDone.Name = strSummary

If Err.Number <> 0 Then
    ActiveWorkbook.Sheets(strSummary).Delete
    shtDone.Name = strSummary
    Err.Clear
End If

firstSheet = True

For Each wksht In ActiveWorkbook.Sheets
    
    If wksht.Name = strSummary Then GoTo nxtSht
    
    lstRow = shtDone.Cells(Rows.Count, 1).End(xlUp).Row
    wksht.[a1].CurrentRegion.Copy shtDone.Cells(lstRow + 1, 1).Select

    If bolTitles = True And firstSheet = False Then
        Rows(lstRow + 1).Delete
    Else
        If bolTab = True And firstSheet = True Then
            lgTabCol = shtDone.Cells(2, Columns.Count).End(xlToLeft).Column + 1
            shtDone.Cells(2, lgTabCol) = strTabTitle
            lstRow = lstRow + 1
        End If
    End If
    
    If bolTab = True Then
        shtDone.Cells(lstRow + 1, lgTabCol) = wksht.Name
    End If
        
    firstSheet = False

nxtSht:
Next

If bolTab = True Then
    Intersect(ActiveSheet.UsedRange, Columns(lgTabCol)).Offset(1, 0).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    Columns(lgTabCol).Copy
    ActiveSheet.PasteSpecial Paste:=xlPasteValues
    application.CutCopyMode = False
End If

Call TurnOffAllUpdates(False)
End Sub

private Sub TurnOffAllUpdates(blSwitchOff As Boolean)

If blSwitchOff Then
    application.ScreenUpdating = False
    application.Calculation = xlCalculationManual
Else
    application.ScreenUpdating = True
    application.Calculation = xlCalculationAutomatic
End If

End Sub

Open in new window

0
 

Author Comment

by:BBlu
ID: 35185400
"Only comments can appear after sub"

should I move the End Sub down a few lines?

End Sub

Call consolidateSheets

Application.ScreenUpdating = True
0
 
LVL 39

Expert Comment

by:nutsch
ID: 35185446
Sorry about that.


Call consolidateSheets

Application.ScreenUpdating = True

End Sub

Open in new window

0
 

Author Comment

by:BBlu
ID: 35185453
It's okay.  I'm going to walk through it so I can learn how it works, but I wanted to make sure I get you before you take off.  I'm not sure what time zone you are in.
0
 

Author Comment

by:BBlu
ID: 35185497
Thanks, Nutsch.  It worked exactly how I probably said it.  But what I meant to say and want is for the data to be on one sheet.  I'm trying to compile it all into one sheet so I can look for something, an error we may have made.
0
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 
LVL 39

Expert Comment

by:nutsch
ID: 35185520
The consolidatesheets macro should do just that.

Try running it.

T
0
 

Author Comment

by:BBlu
ID: 35185578
I ran it...but it puts them all onto separate sheets.  See attached.
consolidateSheetsMacro.xlsx
0
 
LVL 39

Expert Comment

by:nutsch
ID: 35185644
Not my afternoon, BBlu. Here is the update consolidatesheets macro. My apologies for this mess, I'm usually much better at this (and so are most experts around here).

Thomas
Sub consolidateSheets()
Dim shtDone As Worksheet, lstRow As Long
Dim wksht As Worksheet, firstSheet As Boolean

'requires TurnOffAllUpdates macro

Const bolTitles As Boolean = True 'True if sheets have titles, false if they don't
Const strSummary As String = "All" ' update to the name of the consolidated destination
Const bolTab As Boolean = True 'get data from tab name ? True / False
Const strTabTitle As String = "Type" 'title of column from tab name if bolTab=true
Dim lgTabCol As Long

Call TurnOffAllUpdates(True)

Set shtDone = Sheets.Add

On Error Resume Next
shtDone.Name = strSummary

If Err.Number <> 0 Then
    ActiveWorkbook.Sheets(strSummary).Delete
    shtDone.Name = strSummary
    Err.Clear
End If

firstSheet = True

For Each wksht In ActiveWorkbook.Sheets
    
    If Not UCase(Left(wksht.Name, 4)) = "MAIN" Then GoTo nxtSht
    
    lstRow = shtDone.Cells(Rows.Count, 1).End(xlUp).Row
    wksht.[a1].CurrentRegion.Copy shtDone.Cells(lstRow + 1, 1)

    If bolTitles = True And firstSheet = False Then
        Rows(lstRow + 1).Delete
    Else
        If bolTab = True And firstSheet = True Then
            lgTabCol = shtDone.Cells(2, Columns.Count).End(xlToLeft).Column + 1
            shtDone.Cells(2, lgTabCol) = strTabTitle
            lstRow = lstRow + 1
        End If
    End If
    
    If bolTab = True Then
        shtDone.Cells(lstRow + 1, lgTabCol) = wksht.Name
    End If
        
    firstSheet = False

nxtSht:
Next

If bolTab = True Then
    Intersect(ActiveSheet.UsedRange, Columns(lgTabCol)).Offset(1, 0).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
    Columns(lgTabCol).Copy
    ActiveSheet.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
End If

Call TurnOffAllUpdates(False)
End Sub

Open in new window

0
 

Author Comment

by:BBlu
ID: 35185722
No problem, Nutsch.  I'm the one who should be apologizes for being such a newbie!  LOL.  Let me try the new one now.
0
 

Author Comment

by:BBlu
ID: 35185731
It looks like I need to run this new macro on the workbook that the other one created.  Is that correct?
0
 
LVL 39

Expert Comment

by:nutsch
ID: 35185745
It's correct, but the call consolidatesheets that is before the end sub should do it automatically if you rerun from the beginning.
0
 

Author Comment

by:BBlu
ID: 35185798
That works just fine, Thomas.  Outside of a few kinks, which I can try to figure out it gets me what I need.  I like how you added the column for the sheet name.  Is there an easy way to make that column (and/or change the sheet name) to the file name?  If that is another question altogether, I can certainly close this and reopen.  I've increased the points, though, just in case you have an idea and we can just keep it in this same question.
0
 
LVL 39

Accepted Solution

by:
nutsch earned 500 total points
ID: 35185809
Try this update on the consolidate workbooks macro.


Sub ConsolidateFiles()
'REQUIREMENTS:
'    - Function GetSubFolders

'Creates a new workbook with path to all files in folder and subfolders
'Consolidate the first sheet of all the workbooks in the folder and its subfolders

Application.ScreenUpdating = False 'disable screen updating to avoid screen flashing
Dim FileName As String, intFileCount As Long, strFullPath As String
Const strPath As String = "C:\TEMP\SplitFiles" 'update to your file path
Dim myArr, i As Long
Dim wbk1 As Workbook, wbk2 As Workbook

'myArr = GetSubFolders(strPath)
Set wbk1 = Workbooks.Add


'For i = LBound(myArr) To UBound(myArr)

    FileName = Dir(strPath & "\*.xls") '"\" & myArr(i) & "\*.xls")
    Do While FileName <> ""
       intFileCount = intFileCount + 1
       
       strFullPath = strPath & "\" & FileName '"\" & myArr(i) & "\" & FileName
       
'**************************LIST FILES******************************
'       wbk1.Sheets(1).Cells(intFileCount, 1) = strFullPath
'      wbk1.Sheets(1).Cells(intFileCount, 2) = FileName
'******************************************************************

'***********************CONSOLIDATE FILES**************************
    Set wbk2 = Workbooks.Open(strFullPath)
    On Error Resume Next
    wbk2.Sheets(1).Copy After:=wbk1.Sheets(1)
    wbk2.Close False

    If Err.Number = 0 Then
        wbk1.ActiveSheet.Name = Left(FileName, InStr(FileName, ",") + 2) 'wbk2.name
    Else
        wbk1.Sheets(1).Cells(intFileCount, 3) = "Error"
        Err.Clear
    End If

    With wbk1.ActiveSheet
        Dim colFileName As Long
        colFileName = .Cells(1, Columns.Count).End(xlToLeft).Column + 1
        .Cells(1, colFileName) = "Origin File"
        .Range(.Cells(2, colFileName), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, colFileName)) = FileName
    End With
    
    Set wbk2 = Nothing
'******************************************************************

       FileName = Dir
    Loop

wbk1.Sheets(1).Delete

'Next


Call consolidatesheets

Application.ScreenUpdating = True

End Sub

Open in new window

0
 

Author Comment

by:BBlu
ID: 35185859
That is perfect!  Thanks for working through this with me, Thomas.  
0
 
LVL 39

Expert Comment

by:nutsch
ID: 35185866
My pleasure.

T
0
 

Author Comment

by:BBlu
ID: 35185879
I also just read your profile.  I, too, am a Finance/Accounting guy in California.  I'm currently the VP of Finance for a company in the San Jose Area.  But I love just learning more and more about building applications to make my life easier.  I thought I'd share some of these thoughts (among other things) with the world, so I started a blog: BobbyBluford.com.  I'd love to brainstorm with you or have you contribute some of your insights at some point.  heck, I'd even like to have coffee or something if you are anywhere near the Bay Area.  Either way, thanks again for taking the time to help newbies like me learn more.
0
 

Author Closing Comment

by:BBlu
ID: 35185932
Perfect!  Thanks for taking the time to really understand what I was looking for and help me through it, even when I didn't explain it concisely the first time.
0
 
LVL 39

Expert Comment

by:nutsch
ID: 35385616
I checked out your blog and it's pretty interesting. I'm in Napa County so at the other end of the Bay from you, but would love to meet if you're ever in the neighborhood.

Thomas
0
 

Author Comment

by:BBlu
ID: 35388428

I'll be up there soon I'm sure.  I'd love to meet, as well.  Shoot me an email at bobby@bobbybluford.com so I have your information.  Heck, you're ALWAYS welcome to lend some helpful pointers and tips.  I'm just a newbie at this stuff ;)
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

INDEX and MATCH can be used to great effect to replace HLOOKUP and VLOOKUP as it does not have the limitation of needing the data to be sorted so that the reference value is in the first column or row. It also has the ability to perform a bi-directi…
How to quickly and accurately populate Word documents with Excel data, charts and images (including Automated Bookmark generation) David Miller (dlmille) Synopsis In this article you’ll learn how to use ExcelToWord! to copy data,charts, shapes …
The viewer will learn how to simulate a series of coin tosses with the rand() function and learn how to make these “tosses” depend on a predetermined probability. Flipping Coins in Excel: Enter =RAND() into cell A2: Recalculate the random variable…
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …

762 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

26 Experts available now in Live!

Get 1:1 Help Now