Run code for multiple worksheets in a workbook & Column Formatting

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

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
 
1 - Where/how do I adjust the columns to automatically fit the largest
item?

Cells.EntireColumn.AutoFit
workbook, each worksheet has the same format?

For Each ThisWS in Worksheets
''Your code
Next
(like a procedure)?

Include it in the workbook itself or make it an add-in.
another cell, that the value of that cell reference is copied, currently I
am getting a cell with #ref.

Do a Copy and then a Paste Special, Values:

ThisWS.Range(firstrow & ":" & lastrow).Copy
Range("A1").PasteSpecial xlPasteValues
 
Back
Top