The code below looks at a spreadsheet with 8 different reports that all begin with the header "Summary of...". It finds each instance of the word "Summary", copies each report into a new file and then names that file based on the contents of the header and the sheet name. I have 4 questions:
1 - Where/how do I adjust the columns to automatically fit the largest item?
2 - How can I set this up to run for multiple worksheets within the workbook, each worksheet has the same format?
4 - Is there any way that when I copy a cell that has a reference to another cell, that the value of that cell reference is copied, currently I am getting a cell with #ref.
3 - How do I save this so that it can be executed by multiple users - (like a procedure)?

I appreciate all your help!
Shaun
Sub Extract()
Dim sFind As String
Dim ThisWS As Worksheet
Dim NewWS As Worksheet
Dim WSname As String
Dim NewWkb As Workbook
Dim StartCell As Range
Dim NextCell As Range
Dim firstAdd As String
Dim firstrow As Long
Dim lastrow As Long
sFind = "Summary"

Set ThisWS = ActiveSheet
WSname = ThisWS.Name


With ThisWS
Set StartCell = .Cells.Find(what:=sFind, _
after:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
lookat:=xlPart, _
searchdirection:=xlNext, _
searchorder:=xlByRows, _
MatchCase:=False)
End With


If Not StartCell Is Nothing Then
firstAdd = StartCell.Address
Do
firstrow = StartCell.Row
Set NextCell = ThisWS.Cells.FindNext(StartCell)

If NextCell Is Nothing Or NextCell.Address = firstAdd Then
lastrow = ThisWS.Range("A65000").End(xlUp).Row + 2
Else
lastrow = NextCell.Row - 1
End If


Set NewWkb = Workbooks.Add(xlWBATWorksheet)


ThisWS.Range(firstrow & ":" & lastrow).Copy Destination:=ActiveSheet.Range("A1")
NewWkb.SaveAs Filename:=(WSname & Mid$(ActiveSheet.Range("A1").Value, 11, 25) & ".xls")
NewWkb.Close SaveChanges:=False

Set StartCell = NextCell
Loop Until StartCell.Address = firstAdd Or StartCell Is Nothing

End If

End Sub