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

VBA: SQL Connection String and Some Data Formatting

'The below code is for data formatting to use in a SQL query
'We are using connection string to pull data using SQL query
'In comments, below, the code is explained. This is also for future reference, we can copy blocks and use
Sub Amiq()
Sheets("New").Columns("A").ClearContents
Sheets("New").Columns("B").ClearContents
'The above lines clear the contents of A Worksheet namely 'New' from Columns A & B
Sheets("AuditPortal").Columns("R").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("New").Columns("A"), Unique:=True
'The above line copies the column 'R' from Worksheet namely 'AuditPortal', removes duplicates  and paste it in Sheet 'New' and Column A
ThisWorkbook.Worksheets("New").Select
'Select the Sheet 'New'
'In below lines we are using For Loop and for all the Column A rows starting from 2, storing their value in variable SDest after adding single quotes and comma along
'and then along doing some more formatting i.e. Left and Len Function to remove the last comma and adding a single quote at start and finally pasting it in Column 2's first cell
SDest = ""
For iCounter = 2 To WorksheetFunction.CountA(Columns(1))
SDest = SDest & "'" & Cells(iCounter, 1).Value & "'" & ","
Next iCounter
Cells(1, 2).Value = "'" & Left(SDest, Len(SDest) - 1) & ")"
'Below is the SQL connection string. We are first selecting the sheet namely 'sqlResult'
'Our SQL is pasted in Cells(1, 2) of same sheet
'Clearing the range a5:i1000 as we want our results to appear there. A to I range is determined after looking at the columns in our select statement SQL
'Change the name of server from 'OurServer'
ThisWorkbook.Worksheets("sqlResult").Select
Dim sql
sql = Sheets("sqlResult").Cells(1, 2)
Range("a5:I1000") = ""
Dim connString
connString = "ODBC;DSN=OurServer;Description=OurServer;Trusted_Connection=Yes"
Dim thisQT As QueryTable
With ActiveSheet.QueryTables.Add(Connection:=connString, Destination:=Range("a5"))
.BackgroundQuery = False
.sql = sql
.Refresh BackgroundQuery:=True
End With
End Sub

VBA Code to Combine multiple workbooks in one workbook sheet

We can use the below code to combine multiple workbook in a sheet of single workbook and then save it as well.
 
We first need to have all the workbooks in one folder, they should have same headers. Then open a new workbook and add the below code in a module and run it.
 
We just need to change the path of folder where we have multiple workbooks and then the second path where we will save new file.
 
Sub Merge2MultiSheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = "C:\Users\khan\Desktop\Weekly Snaps\" 'Path address
Set wbDst = Workbooks.Add(xlWBATWorksheet)
strFilename = Dir(MyPath & "\*.xlsx", vbNormal)
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Set wsSrc = wbSrc.Worksheets(1)
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbSrc.Close False
strFilename = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True

    Dim i As Integer
    Dim xTCount As Variant
    Dim xWs As Worksheet
    On Error Resume Next
    xTCount = 1
    Set xWs = ActiveWorkbook.Worksheets.Add(Sheets(1))
    xWs.Name = "Combined"
    Worksheets(2).Range("A1").EntireRow.Copy Destination:=xWs.Range("A1")
    For i = 2 To Worksheets.Count
        Worksheets(i).Range("A1").CurrentRegion.Offset(CInt(xTCount), 0).Copy _
               Destination:=xWs.Cells(xWs.UsedRange.Cells(xWs.UsedRange.Count).Row + 1, 1)
    Next
   
   
    Dim xWs2 As Worksheet
     Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    For Each xWs2 In Application.ActiveWorkbook.Worksheets
        If xWs2.Name <> "Combined" Then
            xWs2.Delete
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    ActiveWorkbook.SaveAs Filename:="C:\Users\khan\Desktop\Example.xlsx" 'Path address
End Sub