So, working now as an Excel Trainer cum Reports Analyst, I have to create small macro programs that will aid the office in report generation. So, let me share, a simple Macro Program to that shall consolidate / combine different worksheets from several workbooks into one summary file.
I hope these will help you in your macro learning.
![]() |
different worksheets of different workbooks |
These files were saved in one folder, and the idea is to combine different data from different worksheet and combine them all in one separate workbook say in a different folder.
![]() |
the summary file (some rows were hidden for visual purpose) |
So, in my Summary File, I write these:
Sub createSummarySheet()
Dim SummarySht As Worksheet
Dim FolderPath As String
Dim BlankRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range
Dim lastrow As Long
Set SummarySht = ActiveWorkbook.Worksheets(1)
FolderPath = "C:\Tickets\" 'this is the folder where you will save your different workbooks for consolidation
BlankRow = 2
FileName = Dir(FolderPath & "*.xl*")
SummarySht.Range("A2:D" & SummarySht.Rows.Count).ClearContents
Do While FileName <> ""
Set WorkBk = Workbooks.Open(FolderPath & FileName)
'call combine function
Combine
SummarySht.Range("A" & BlankRow).Value = FileName
lastrow = WorkBk.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Set SourceRange = WorkBk.Worksheets(1).Range(Cells(2, 1), Cells(lastrow, 3))
Set DestRange = SummarySht.Range("B" & BlankRow)
Set DestRange = DestRange.Resize(SourceRange.Rows.Count, SourceRange.Columns.Count)
DestRange.Value = SourceRange.Value
BlankRow = BlankRow + DestRange.Rows.Count
WorkBk.Close saveChanges:=False
FileName = Dir()
Loop
SummarySht.Columns.AutoFit
SummarySht.Range("A1:D" & SummarySht.UsedRange.Rows.Count).Borders.LineStyle = xlContinuous
ActiveWorkbook.Save
End Sub
----
In another module to combine the different worksheets before being captured into summary file, I write these:
Sub Combine()
Dim J As Integer
On Error Resume Next
Sheets(1).Select
Worksheets.Add ' add a sheet in first place
Sheets(1).Name = "Sheet1"
' copy headings
Sheets(2).Activate
Range("A1").EntireRow.Select
Selection.Copy Destination:=Sheets(1).Range("A1")
' work through sheets
For J = 2 To Sheets.Count ' from sheet 2 to last sheet
Sheets(J).Activate ' make the sheet active
Range("A1").Select
Selection.CurrentRegion.Select ' select all cells in this sheets
' select all lines except title
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
' copy cells selected in the new sheet on last line
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
Worksheets("Sheet1").Activate
End Sub
No comments:
Post a Comment