If you find any post useful then, please do share with others. Thanks!

Popular Posts

Contact

Email me

Need help and that also free? I like to learn this way, in case of any question or for a small task, please feel free to email me with details and example data, if required.

Wednesday, April 4, 2018

Merging multiple worksheets into one

This code is shared by EDWARD FERKING JR
Special Thanks to him for sharing this. true-north-usa.com  (His Company Website)

We can use below VBA code for same.

Each time we run it, it will insert a new worksheet at the far left of the active workbook and it will vertically summarize (Values and Formats only…aka a static snapshot of) all the worksheets in the active workbook (NOT including any other worksheet summary pages previously generated by the macro).

Sub SummarizeWorkSheets()
Dim wks As Worksheet, sWks As Worksheet, Ur As Range, I As Integer
Dim sWksc As Integer, sWksr As Long, CurrDate As Date, DateStr As String
Application.ScreenUpdating = False: Sheets(1).Select
Set sWks = ActiveWorkbook.Worksheets.Add: CurrDate = Now()
DateStr = Application.Text(CurrDate, "mm dd yyyy hhmmss AM/PM")
sWks.Name = "WbSumry " & DateStr
sWks.Cells(1, 1) = "Workbook Summary of All Worksheets as of " & DateStr
sWks.Cells(1, 1).Font.Size = 22: sWks.Cells(3, 1).Select: ActiveWindow.FreezePanes = True
For Each wks In ActiveWorkbook.Worksheets
If (Not wks.Name Like "WbSumry*") Then
sWks.Activate
sWksr = sWks.UsedRange.Rows.Count: sWksc = sWks.UsedRange.Columns.Count
If sWksc < 40 Then sWksc = 40
sWks.Cells(sWksr + 3, 1) = "Values and Formats From Worksheet [ " & wks.Name & " ]"
sWks.Cells(sWksr + 3, 1).Font.Size = 14
With sWks.Range(Cells(sWksr + 2, 1), Cells(sWksr + 2, sWksc)).Borders(xlEdgeBottom)
.LineStyle = xlDouble: .ColorIndex = xlAutomatic: .TintAndShade = 0: .Weight = xlThick
End With: wks.Activate: Set Ur = wks.UsedRange: Ur.Select: Selection.Copy
sWks.Activate: sWks.Cells(sWksr + 5, 1).Select:
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
sWksr = sWks.UsedRange.Rows.Count: sWksc = sWks.UsedRange.Columns.Count
End If: sWks.Activate:: Next wks
sWks.Cells(1).Select: ActiveWindow.ScrollRow = 1: Application.ScreenUpdating = True
MsgBox ("Worksheet Summary Complete")
End Sub