Consolidation of workbooks in the same file to a single sheet in a master

**Jaspabl** · 11-10-2011, 12:09 AM

Hi, I have just developed an automated purchase order form that the users save in a daily folder, with a different file name of each new purchase order. What I need to do is to put certain information from selected cells of these forms into a summary workbook to provide the owner with a daily summary of orders made. I know it can be done, but the consolidation program I have is for a much more complex consolidation. Does anyone have a simple consolidation program that will just take information from certain cells and put in in a summary?

**pike** · 11-10-2011, 01:20 AM

hi Jaspabl
Weclome to the forum
Jerry has many examples herehttps://sites.google.com/a/madrocket.../wbs-to-sheets

**Jaspabl** · 11-10-2011, 05:28 PM

Thanks Pike, I think I have found what I need. Just need to customise, which I think is not a friday job! Brain dead from 2 weeks of designing, developing and training users....

**pike** · 11-11-2011, 06:29 PM

hi Jaspabl

how did it go ?

**Jaspabl** · 11-14-2011, 01:34 AM

Still batteling on. The 4 options don't seem to quite do it. Very frustrating! All I need it to do is to go to each file, select a certain sheet and copy 1 line to be pasted into a master sheet in the consolodation spreadsheet to create a list that will be totaled on the bottom line of the sheet. I must be missing something somewhere!

**pike** · 11-14-2011, 01:40 AM

Can you adapt this one

Option Explicit

Sub ConsolidateSheetsFromWorkbooks()
'Author:    Jerry Beaucaire, ExcelForum.com
'Date:      1/5/2011
'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
Dim wbData As Workbook, wbMain As Workbook
Dim wsMain As Worksheet, wsData As Worksheet
Dim LR As Long, NR As Long
Dim fPath As String, fName As String

Set wbMain = ThisWorkbook

                                    '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

    Do While Len(fName) > 0
        If fName <> ThisWorkbook.Name Then
            Set wbData = Workbooks.Open(fPath & fName)
            For Each wsData In wbData.Worksheets
                Set wsMain = wbMain.Sheets(wsData.Name)
                NR = wsMain.Range("A" & Rows.Count).End(xlUp).Row + 1
                With wsData
                    LR = .Range("A" & .Rows.Count).End(xlUp).Row
                    .Range("A2:A" & LR).EntireRow.Copy wsMain.Range("A" & NR)
                End With
            Next wsData
            
            wbData.Close False
        End If
        
        fName = Dir                 'queue up next filename
    Loop

Application.ScreenUpdating = True
End Sub

**Jaspabl** · 11-24-2011, 06:20 PM

Hi Pike, I have it almost working with one tiny problem, that defeats the whole purpose of the spreadheets! What I need it to do is to find the next row without data and select the cell in columnA and paste the values. Currently it just pastes in row 2 (I know it will be something to do with the "Range ("A2:A" & LR):

Application.ScreenUpdating = False
Sheets("Form accS2").Select
Range("B2").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Date = Range("B2").Value
PO = Range("B9").Value

Sheets("Form accS2").saveas Filename:="C:\Documents and Settings\Julie Anderson\My Documents\Dropbox\Beecham\Audi Central Coast WIP\Automation\" & Year(Now) & "-" & Month(Now) & "-" & Day(Now) & "_" & PO & ".xls"

Application.ScreenUpdating = True
ActiveWindow.SelectedSheets.PrintOut Copies:=1

Sheets("Purchases").Select
Range("A2:I2").Copy

Workbooks.Open ("Draft Daily Tracking Spreadsheet.xlsm")
Sheets("purchases").Select
LR = Cells.Find("*", Cells(Rows.Count, Columns.Count), _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Range("A2:A" & LR).EntireRow.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Workbooks("Draft Daily Tracking Spreadsheet.xlsm").Save

**Jaspabl** · 11-24-2011, 10:04 PM

Very pleased to say I have finally solved my problem. Just had a total blank about it, and it was a fairly easy fix in the end (I hope this can help others out there). Both files need to be in the same folder:

Sub dailyreport()
Application.ScreenUpdating = False
Sheets("Form accS2").Select
Range("B2").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Date = Range("B2").Value
PO = Range("B9").Value

Sheets("Form accS2").saveas Filename:="C:\(File Path)" & Year(Now) & "-" & Month(Now) & "-" & Day(Now) & "_" & PO & ".xls"

Application.ScreenUpdating = True
ActiveWindow.SelectedSheets.PrintOut Copies:=1

Sheets("Purchases").Select
Range("A2:I2").Copy

Workbooks.Open ("Draft Daily Tracking Spreadsheet.xlsm")
Sheets("purchases").Select
NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(NextRow, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Workbooks("Draft Daily Tracking Spreadsheet.xlsm").Save

End Sub

**ConneXionLost** · 11-25-2011, 12:11 AM

Your post does not comply with Rule 3 of our Forum RULES. Use code tags around code. Posting code without them makes your code hard to read and difficult to be copied for testing. Highlight your code and click the # at the top of your post window. For more information about these and other tags, found here