Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.misc
|
|||
|
|||
Multiple workbooks to one worksheet
Hi,
I am needing a VBA script to combine multiple workbooks of multiple sheets to a single worksheet. Basically i have a lot of workbooks which have all the same headers but i want to combine all of these into one big speadsheet. I have found the script below which i have tried to use but it copies over the top of every worksheet so it will only show the last one. any ideas of how i can make it join to the bottom rather than over the top? thank you! Sub ImportDistricts() Dim x As Long, z As Variant Dim bk As Workbook, sh As Worksheet Dim sh1 As Worksheet ' ' Change the next line to reflect the proper ' name and workbook where the data will be ' consolidated ' Set sh = Workbooks("SummaryBecsAll.xls").Worksheets("BecsAl l") z = Application.GetOpenFilename(FileFilter:= _ "Excel files (*.xls), *.xls", MultiSelect:=True) If Not IsArray(z) Then MsgBox "Nothing selected" Exit Sub End If 'Open loop for action to be taken on all selected workbooks. For x = 1 To UBound(z) 'Open the workbook(s) that were selected. Set bk = Workbooks.Open(z(x)) 'Check if sheet Mon1 exists 'Check if sheet Mon2 exists 'Check if sheet Mon3 exists 'Check if sheet Mon4 exists 'Check if sheet Mon5 exists 'Dont process a sheet if its name is "cover" On Error Resume Next Set sh1 = bk.Worksheets("Mon1") Set sh1 = bk.Worksheets("Mon2") Set sh1 = bk.Worksheets("Mon3") Set sh1 = bk.Worksheets("Mon4") Set sh1 = bk.Worksheets("Mon5") On Error GoTo 0 ' if it exists, copy the data If Not sh1 Is Nothing Then Set rng = sh1.Range("A2:X1646") Set rng1 = sh.Cells(Rows.Count, 1).End(xlUp)(2) rng.Copy rng1.PasteSpecial xlValues rng1.PasteSpecial xlFormats End If 'Close the District workbook without saving it. bk.Close False Next x 'Message box to inform user the job is complete. MsgBox "The import is complete.", 64, "Done !!" End Sub |
#2
Posted to microsoft.public.excel.misc
|
|||
|
|||
Multiple workbooks to one worksheet
Try some code like the following: Sub BigMerge() Dim DestCell As Range Dim DataColumn As Variant Dim NumberOfColumns As Variant Dim WB As Workbook Dim DestWB As Workbook Dim WS As Worksheet Dim FileNames As Variant Dim N As Long Dim R As Range Dim StartRow As Long Dim LastRow As Long Dim RowNdx As Long ' Create a new workbook for the consolidated ' data. Set DestWB = Workbooks.Add ' OR use the ActiveWorkbook: 'Set DestWB = ActiveWorkbook ' OR use an open workbook 'Set DestWB = Workbooks("Book1.xls") ' DestCell is the first cell where the consolidated ' data will be written. Set DestCell = DestWB.Worksheets(1).Range("A1") ' DataColumn is the column on the worksheets to be ' consolidated where the actual data is. Data will ' be copied from this column. DataColumn = "A" ' NumberOfColumns is the number of columns on each ' worksheet to be consolidated from which data will ' be copied. E.g., if your data is in range A1:J100, ' NumberOfColumns would be 10. NumberOfColumns = 2 ' StartRow is the row on the worksheets to be consolidated ' where the data starts. If your worksheet have heading/summary ' rows at the top, set this value to the row number where ' the actual data starts. StartRow = 1 ' Get the workbooks to consolidate FileNames = Application.GetOpenFilename( _ filefilter:="Excel Files (*.xls*),*.xls*", _ Title:="Select the workbooks to merge.", MultiSelect:=True) If IsArray(FileNames) = False Then If FileNames = False Then ' User cancelled open dialog. get out. Exit Sub End If End If ' Loop through all the selected files. For N = LBound(FileNames) To UBound(FileNames) ' Open the workbook Set WB = Workbooks.Open(Filename:=FileNames(N), ReadOnly:=True) ' Loop through all the worksheets in the workbook For Each WS In WB.Worksheets With WS ' Test if worksheet has content. It must have ' at least two cells with content. Otherwise, ' it is assumed to be empty and will not be ' processed. If WS.UsedRange.Cells.Count 1 Then ' Get the last row in DataColumn ' that has data. LastRow = .Cells(.Rows.Count, DataColumn). _ End(xlUp).Row ' Loop through the rows, statring at StartRow ' and going down to LastRow. For RowNdx = StartRow To LastRow ' Copy the cells on row RowNdx ' starting in DataColumn for NumberOfColumns' ' columns wide. Data is copied to ' DestCell. .Cells(RowNdx, DataColumn). _ Resize(1, NumberOfColumns).Copy _ Destination:=DestCell ' Move the DestCell down one row. Set DestCell = DestCell(2, 1) Next RowNdx End If End With Next WS ' close the workbook. WB.Close savechanges:=False Next N End Sub Cordially, Chip Pearson Microsoft Most Valuable Professional Excel Product Group, 1998 - 2009 Pearson Software Consulting, LLC www.cpearson.com (email on web site) On Thu, 26 Mar 2009 03:39:07 -0700, Steve wrote: Hi, I am needing a VBA script to combine multiple workbooks of multiple sheets to a single worksheet. Basically i have a lot of workbooks which have all the same headers but i want to combine all of these into one big speadsheet. I have found the script below which i have tried to use but it copies over the top of every worksheet so it will only show the last one. any ideas of how i can make it join to the bottom rather than over the top? thank you! Sub ImportDistricts() Dim x As Long, z As Variant Dim bk As Workbook, sh As Worksheet Dim sh1 As Worksheet ' ' Change the next line to reflect the proper ' name and workbook where the data will be ' consolidated ' Set sh = Workbooks("SummaryBecsAll.xls").Worksheets("BecsAl l") z = Application.GetOpenFilename(FileFilter:= _ "Excel files (*.xls), *.xls", MultiSelect:=True) If Not IsArray(z) Then MsgBox "Nothing selected" Exit Sub End If 'Open loop for action to be taken on all selected workbooks. For x = 1 To UBound(z) 'Open the workbook(s) that were selected. Set bk = Workbooks.Open(z(x)) 'Check if sheet Mon1 exists 'Check if sheet Mon2 exists 'Check if sheet Mon3 exists 'Check if sheet Mon4 exists 'Check if sheet Mon5 exists 'Dont process a sheet if its name is "cover" On Error Resume Next Set sh1 = bk.Worksheets("Mon1") Set sh1 = bk.Worksheets("Mon2") Set sh1 = bk.Worksheets("Mon3") Set sh1 = bk.Worksheets("Mon4") Set sh1 = bk.Worksheets("Mon5") On Error GoTo 0 ' if it exists, copy the data If Not sh1 Is Nothing Then Set rng = sh1.Range("A2:X1646") Set rng1 = sh.Cells(Rows.Count, 1).End(xlUp)(2) rng.Copy rng1.PasteSpecial xlValues rng1.PasteSpecial xlFormats End If 'Close the District workbook without saving it. bk.Close False Next x 'Message box to inform user the job is complete. MsgBox "The import is complete.", 64, "Done !!" End Sub |
#3
Posted to microsoft.public.excel.misc
|
|||
|
|||
Multiple workbooks to one worksheet
This works great Chip thank you mate!
is there anyway of it being able to take the blank rows out also? Thanks for your help upto now! "Chip Pearson" wrote: Try some code like the following: Sub BigMerge() Dim DestCell As Range Dim DataColumn As Variant Dim NumberOfColumns As Variant Dim WB As Workbook Dim DestWB As Workbook Dim WS As Worksheet Dim FileNames As Variant Dim N As Long Dim R As Range Dim StartRow As Long Dim LastRow As Long Dim RowNdx As Long ' Create a new workbook for the consolidated ' data. Set DestWB = Workbooks.Add ' OR use the ActiveWorkbook: 'Set DestWB = ActiveWorkbook ' OR use an open workbook 'Set DestWB = Workbooks("Book1.xls") ' DestCell is the first cell where the consolidated ' data will be written. Set DestCell = DestWB.Worksheets(1).Range("A1") ' DataColumn is the column on the worksheets to be ' consolidated where the actual data is. Data will ' be copied from this column. DataColumn = "A" ' NumberOfColumns is the number of columns on each ' worksheet to be consolidated from which data will ' be copied. E.g., if your data is in range A1:J100, ' NumberOfColumns would be 10. NumberOfColumns = 2 ' StartRow is the row on the worksheets to be consolidated ' where the data starts. If your worksheet have heading/summary ' rows at the top, set this value to the row number where ' the actual data starts. StartRow = 1 ' Get the workbooks to consolidate FileNames = Application.GetOpenFilename( _ filefilter:="Excel Files (*.xls*),*.xls*", _ Title:="Select the workbooks to merge.", MultiSelect:=True) If IsArray(FileNames) = False Then If FileNames = False Then ' User cancelled open dialog. get out. Exit Sub End If End If ' Loop through all the selected files. For N = LBound(FileNames) To UBound(FileNames) ' Open the workbook Set WB = Workbooks.Open(Filename:=FileNames(N), ReadOnly:=True) ' Loop through all the worksheets in the workbook For Each WS In WB.Worksheets With WS ' Test if worksheet has content. It must have ' at least two cells with content. Otherwise, ' it is assumed to be empty and will not be ' processed. If WS.UsedRange.Cells.Count 1 Then ' Get the last row in DataColumn ' that has data. LastRow = .Cells(.Rows.Count, DataColumn). _ End(xlUp).Row ' Loop through the rows, statring at StartRow ' and going down to LastRow. For RowNdx = StartRow To LastRow ' Copy the cells on row RowNdx ' starting in DataColumn for NumberOfColumns' ' columns wide. Data is copied to ' DestCell. .Cells(RowNdx, DataColumn). _ Resize(1, NumberOfColumns).Copy _ Destination:=DestCell ' Move the DestCell down one row. Set DestCell = DestCell(2, 1) Next RowNdx End If End With Next WS ' close the workbook. WB.Close savechanges:=False Next N End Sub Cordially, Chip Pearson Microsoft Most Valuable Professional Excel Product Group, 1998 - 2009 Pearson Software Consulting, LLC www.cpearson.com (email on web site) On Thu, 26 Mar 2009 03:39:07 -0700, Steve wrote: Hi, I am needing a VBA script to combine multiple workbooks of multiple sheets to a single worksheet. Basically i have a lot of workbooks which have all the same headers but i want to combine all of these into one big speadsheet. I have found the script below which i have tried to use but it copies over the top of every worksheet so it will only show the last one. any ideas of how i can make it join to the bottom rather than over the top? thank you! Sub ImportDistricts() Dim x As Long, z As Variant Dim bk As Workbook, sh As Worksheet Dim sh1 As Worksheet ' ' Change the next line to reflect the proper ' name and workbook where the data will be ' consolidated ' Set sh = Workbooks("SummaryBecsAll.xls").Worksheets("BecsAl l") z = Application.GetOpenFilename(FileFilter:= _ "Excel files (*.xls), *.xls", MultiSelect:=True) If Not IsArray(z) Then MsgBox "Nothing selected" Exit Sub End If 'Open loop for action to be taken on all selected workbooks. For x = 1 To UBound(z) 'Open the workbook(s) that were selected. Set bk = Workbooks.Open(z(x)) 'Check if sheet Mon1 exists 'Check if sheet Mon2 exists 'Check if sheet Mon3 exists 'Check if sheet Mon4 exists 'Check if sheet Mon5 exists 'Dont process a sheet if its name is "cover" On Error Resume Next Set sh1 = bk.Worksheets("Mon1") Set sh1 = bk.Worksheets("Mon2") Set sh1 = bk.Worksheets("Mon3") Set sh1 = bk.Worksheets("Mon4") Set sh1 = bk.Worksheets("Mon5") On Error GoTo 0 ' if it exists, copy the data If Not sh1 Is Nothing Then Set rng = sh1.Range("A2:X1646") Set rng1 = sh.Cells(Rows.Count, 1).End(xlUp)(2) rng.Copy rng1.PasteSpecial xlValues rng1.PasteSpecial xlFormats End If 'Close the District workbook without saving it. bk.Close False Next x 'Message box to inform user the job is complete. MsgBox "The import is complete.", 64, "Done !!" End Sub |
#4
Posted to microsoft.public.excel.misc
|
|||
|
|||
Multiple workbooks to one worksheet
See if this code works better. The code checks all the xls files inthe
folder called folder (change as required) and combines all the sheets into a summary table. I did not get a chance to fully test the code. It should work. The code assumes each workbook has a header in row 1 and ther are no errors in the cells like #VALUE. It copies the formating but removes any formulas. I needed to copy the formating because Dates were getting transposed to number. Sub Combinebooks() Application.ScreenUpdating = False 'Assume the summary book is completeley blank Folder = "c:\temp\" NewRow = 2 NewCol = 1 FName = Dir(Folder & "*.xls") With ThisWorkbook.Sheets("Sheet1") Do While FName < "" Set bk = Workbooks.Open(Filename:=Folder & FName) 'check header to see if there are any new headers not 'in summary sheet For Each sht In bk.Sheets LastRow = sht.Cells.SpecialCells(xlCellTypeLastCell).Row LastCol = sht.Cells(1, Columns.Count).End(xlToLeft).Column 'move all the data For RowCount = 2 To LastRow For ColCount = 1 To LastCol ColHeader = sht.Cells(1, ColCount) If ColHeader < "" Then 'search for header in summary sheet Set c = .Rows(1).Find(what:=ColHeader, _ LookIn:=xlValues, lookat:=xlWhole) If c Is Nothing Then 'add header .Cells(1, NewCol) = ColHeader DataCol = NewCol NewCol = NewCol + 1 Else DataCol = c.Column End If If sht.Cells(RowCount, ColCount) < "" Then sht.Cells(RowCount, ColCount).Copy _ Destination:=.Cells(NewRow, DataCol) 'remove formulas .Cells(NewRow, DataCol).Copy .Cells(NewRow, DataCol).PasteSpecial _ Paste:=xlPasteValues End If End If Next ColCount NewRow = NewRow + 1 Next RowCount Next sht bk.Close savechanges:=False FName = Dir() Loop End With Application.ScreenUpdating = True End Sub "Steve" wrote: Hi, I am needing a VBA script to combine multiple workbooks of multiple sheets to a single worksheet. Basically i have a lot of workbooks which have all the same headers but i want to combine all of these into one big speadsheet. I have found the script below which i have tried to use but it copies over the top of every worksheet so it will only show the last one. any ideas of how i can make it join to the bottom rather than over the top? thank you! Sub ImportDistricts() Dim x As Long, z As Variant Dim bk As Workbook, sh As Worksheet Dim sh1 As Worksheet ' ' Change the next line to reflect the proper ' name and workbook where the data will be ' consolidated ' Set sh = Workbooks("SummaryBecsAll.xls").Worksheets("BecsAl l") z = Application.GetOpenFilename(FileFilter:= _ "Excel files (*.xls), *.xls", MultiSelect:=True) If Not IsArray(z) Then MsgBox "Nothing selected" Exit Sub End If 'Open loop for action to be taken on all selected workbooks. For x = 1 To UBound(z) 'Open the workbook(s) that were selected. Set bk = Workbooks.Open(z(x)) 'Check if sheet Mon1 exists 'Check if sheet Mon2 exists 'Check if sheet Mon3 exists 'Check if sheet Mon4 exists 'Check if sheet Mon5 exists 'Dont process a sheet if its name is "cover" On Error Resume Next Set sh1 = bk.Worksheets("Mon1") Set sh1 = bk.Worksheets("Mon2") Set sh1 = bk.Worksheets("Mon3") Set sh1 = bk.Worksheets("Mon4") Set sh1 = bk.Worksheets("Mon5") On Error GoTo 0 ' if it exists, copy the data If Not sh1 Is Nothing Then Set rng = sh1.Range("A2:X1646") Set rng1 = sh.Cells(Rows.Count, 1).End(xlUp)(2) rng.Copy rng1.PasteSpecial xlValues rng1.PasteSpecial xlFormats End If 'Close the District workbook without saving it. bk.Close False Next x 'Message box to inform user the job is complete. MsgBox "The import is complete.", 64, "Done !!" End Sub |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Updating Workbooks from multiple links Workbooks | Excel Worksheet Functions | |||
Consolidate multiple workbooks into a single worksheet | Excel Worksheet Functions | |||
Summary Worksheet from Multiple Workbooks | Excel Worksheet Functions | |||
Combine contents of multiple workbooks into one worksheet | Excel Worksheet Functions | |||
Copy from multiple workbooks and display the original worksheet na | Excel Discussion (Misc queries) |