Solved

How to consolidate data from mulltiple worksheets into a worksheet of a same workbook.

Posted on 2011-03-16
11
285 Views
Last Modified: 2012-05-11
Hello,

I have a workbbok with multiple worksheets.  I need a way to take all data from these worksheets, and combine them into a single workshhet.  Please help.

Thank you.

Kathryn
Test--Master-FY12-Capital-Equipm.xls
0
Comment
Question by:KathrynT
  • 5
  • 4
  • 2
11 Comments
 
LVL 50

Assisted Solution

by:Dave Brett
Dave Brett earned 200 total points
Comment Utility
0
 
LVL 39

Accepted Solution

by:
nutsch earned 300 total points
Comment Utility
Try this code

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
Application.ScreenUpdating = False
firstSheet = True

For Each wksht In ActiveWorkbook.Sheets
    
    If wksht.Name = strSummary Then GoTo nxtSht
    
    wksht.[a152].CurrentRegion.Resize(wksht.Cells(Rows.Count, 1).End(xlUp).Row - 150).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
        Rows(lstRow + 1).Delete 'MERGED TITLE ROW
    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

shtDone.Cells.EntireColumn.AutoFit

Application.ScreenUpdating = True
End Sub

Open in new window


Thomas
0
 
LVL 50

Assisted Solution

by:Dave Brett
Dave Brett earned 200 total points
Comment Utility
Output sample attached

I updated the code from http://www.experts-exchange.com/A_2804.html
to work from row 152 down

Cheers

Dave
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

    Dim rngX As Range

    '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.Activate
                            Set rngX = ws2.Range(ws2.Range("A152"), ws2.Cells(Rows.Count, "A").End(xlUp))
                            rngX.EntireRow.Copy ws1.Cells(rng1.Row + 1 + lrowSpace, ws2.UsedRange.Cells(1).Column)
                            If ws2.Index > 1 Then ws1.Cells(rng1.Row + 1 + lrowSpace, "A").EntireRow.Delete
                        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
                        
                            Set rngX = ws2.Range(ws2.[a152], ws2.Cells(Rows.Count, "A").End(xlUp)).EntireRow
                            rngX.Copy ws1.Cells(1, 1)
                    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

sample.xlsx
0
 

Author Comment

by:KathrynT
Comment Utility
Thank you,  Dave and Nutsch.

I'm going to try your VBA codes now.  And will update you guys.

Kathryn
0
 
LVL 50

Expert Comment

by:Dave Brett
Comment Utility
I'd missed Nutsch's post

I think a points split is fair here presuming you can get both codes to do what you want

(I did attach a sample output. It presumed your file was closed, and I removed your redundant sheet1 from the saves file prior to running my code)

Cheers

Dave

0
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 

Author Comment

by:KathrynT
Comment Utility
 Hi Dave and Nutsch,

I'm little lost here..

1/  First,  I think I need to open my file.
2/  Now I need to insert a new sheet.
3   Then I hold down keys  "ALT" and F11 to open VBA environment.  (Here I can't copy and paste your codes over to my sheet on the right hand side.  It is greyed out.)

Dave, I'm so excited to see your sample file you tested for me.  I have no idea how you got it...but this is definitely a great result.  I hope I can do the same over here.  However, I would refer the code a bit shorter.

Regards,

Kathryn
.
0
 
LVL 39

Assisted Solution

by:nutsch
nutsch earned 300 total points
Comment Utility
For my code

Don't insert a new sheet
go to vba editor
Insert\Module
Copy / Paste my code in the module
Run using F5 from the Editor or in the workbook with Alt+F8

Thomas
0
 
LVL 50

Expert Comment

by:Dave Brett
Comment Utility
>However, I would refer the code a bit shorter.

The shortness doesn't really make a difference, in this case the length is there for robustness and optionalitu. ie shorter code would be more error prone or produce haphazard outcomes

> I have no idea how you got it.

- Place my code in a new workbook ( follow the same instructions Thomas gave above)
- Have your source workbook closed (with first sheet deleted)
- run the code, pick "No" {single file}, then "Ye: {one sheet} then select your workbook via explorer and its done

Cheers

Dave
0
 

Assisted Solution

by:KathrynT
KathrynT earned 0 total points
Comment Utility
Hi Dave and Thomas,

I tried Thomas's code, and it works!!!

You two are real geniuses.  

Dave, I appreciated your help so much.  I'm going to try your code when I have a need to put all worksheets into a different workbook.

I'm ready to accept these solutions.

Many thanks.

Kathryn
0
 
LVL 50

Expert Comment

by:Dave Brett
Comment Utility
Glad to have helped Kathryn, thx for the feedback :)

Dave
0
 

Author Closing Comment

by:KathrynT
Comment Utility
Your Answer:
Hi Dave and Thomas,

I tried Thomas's code, and it works!!!

You two are real geniuses.  

Dave, I appreciated your help so much.  I'm going to try your code when I have a need to put all worksheets into a different workbook.

I'm ready to accept these solutions.

Many thanks.

Kathryn
0

Featured Post

Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

Suggested Solutions

This tutorial explains how to create a series of drop-down lists that are dependent upon prior selections to guide (“force”) the user to make the correct selection and reduce data errors within Microsoft Excel. Excel 2010 was used for this tutorial;…
Many companies are making the switch from Microsoft to Google Apps (https://www.google.com/work/apps/business/). Use this article to learn more about what Google Apps has to offer and to help if you’re planning on migrating to Google Apps. It is …
The viewer will learn how to use the =DISCRINV command to create a discrete random variable, use this command to model a set of probabilities and outcomes in a Monte Carlo simulation, and learn how to find the standard deviation of a set of probabil…
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

743 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

17 Experts available now in Live!

Get 1:1 Help Now