Sub MoveThem() 
    Dim ws As Worksheet, ss As Worksheet, FolderName As String, Wb As Workbook 
    Application.ScreenUpdating = False 
    FolderName = ThisWorkbook.Path 
    For Each ws In ThisWorkbook.Worksheets 
        If ws.Name <> "Temp.sheet" And ws.Name <> "TOC" Then 
            If Wb Is Nothing Then 
                ws.Move 
                Set Wb = ActiveWorkbook 
            Else 
                ws.Move after:=ss 
            End If 
            Set ss = ActiveSheet 
        End If 
    Next ws 
    ThisWorkbook.Activate 
    Wb.SaveAs FolderName _ 
    & "\" & Wb.Sheets(1).Name & ".xls" 
    Wb.Close False 
    MsgBox "Look in folder " & FolderName & " for files ..." 
    Application.ScreenUpdating = True 
End Sub