Hi There,

Underneath sub bugs on:

ws.Range("B6").Sort Key1:=Range("B6"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Any ideas?

Best Regards, Sige


Sub MakeNAMS()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets

ws.Range("B6").Sort Key1:=Range("B6"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Rows("7:7").Delete Shift:=xlUp
ws.Range("B7").Subtotal GroupBy:=2, Function:=xlSum,
TotalList:=Array(3, 4, 5, 6, _
7, 8, 9, 10, 11, 12, 13, 14, 15), Replace:=False,
PageBreaks:=False, _
SummaryBelowData:=True
ActiveWindow.DisplayOutline = True

Next ws
End Sub