Sub Merge_sheets()
Dim ws As Worksheet, lr As Long
Dim formula1 As String
Dim formula2 As String
Application.ScreenUpdating = False
Sheets("Total").Range("A3:C10000").ClearContents
lr2 = Sheets("Total").Cells(Rows.Count, "A").End(xlUp).Row + 1
'
' Extract names for each sheet
'
n = 1
For Each ws In Worksheets
If ws.Name <> "Total" Then
lr1 = ws.Cells(Rows.Count, "A").End(xlUp).Row
ws.Range("A2:A" & lr1).Copy Sheets("Total").Range("A" & lr2)
lr2 = Sheets("Total").Cells(Rows.Count, "A").End(xlUp).Row + 1
n = n + 1
Sheets("Total").Cells(n, "H") = ws.Name
End If
Next ws
With Sheets("Total")
'
' remove duplicates
'
lr2 = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Columns("A:A").Select
.Range("$A$1:$A$" & lr2).RemoveDuplicates Columns:=1, Header:=xlYes
lr2 = .Cells(Rows.Count, "A").End(xlUp).Row
'
' Sort the names (column A)
'
Range("A2:A" & lr2).Select
ActiveWorkbook.Worksheets("Total").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Total").Sort.SortFields.Add Key:=Range("A2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Total").Sort
.SetRange Range("A2:A" & lr2)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'
' Copy formulae from from B2 and C2 down
'
Range("B2:C2").Select
Selection.AutoFill Destination:=Range("B2:C" & lr2), Type:=xlFillDefault
.Cells(2, 1).Select
End With
Application.ScreenUpdating = True
End Sub
Highlighted code creates "Sheets" list for you
Bookmarks