I have modified a procedure I downloaded from Debra Dalgleish's site and show the detail
as below. Basically it looks at a range of values then creates a named worksheet for each
of these values if that worksheet does not already exist. If it does exist it just clears
some ranges and copies in some filtered data. I would be grateful if someone could have a
quick look through to see if I have put in anything in such a way that it would really
slow the operation of the procedure. Don't get me wrong, the procedure does exactly what
it is ecpected to do , it just seems to take a bit of time and I just wonder if there is
anything slowing it. I am sorry I have notes above each operation as I am not the sharpest
pencil in the box when it come to programming and I need to keep track of what I am trying
to do. Don't spend a lot of time on it, as I say it works and is liveable with.
Sub ExtractFields()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("FieldMaster")
Set rng = Range("DatabaseList")
Application.ScreenUpdating = False
r = Sheets("Entries").Cells(Rows.Count, "A").End(xlUp).row
For Each c In Sheets("Entries").Range("A12:A" & r)
' check if sheet exists
If WksExists(c.Value) Then
'Clear existing sheet areas if sheet already exists
Sheets(c.Value).Range("B12:E15").ClearContents
Sheets(c.Value).Range("B23:E28").ClearContents
Sheets(c.Value).Range("J12:N15").ClearContents
Sheets(c.Value).Range("J23:N28").ClearContents
' run advanced filter to get organic applications
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets(c.Value).Range("Q1:Q2"), _
CopyToRange:=Sheets(c.Value).Range("C11:E11"), _
Unique:=False
Else
'If sheet does not exist add it
Set wsNew = Sheets.Add
' enter after last sheet
wsNew.Move After:=Worksheets(Worksheets.Count)
' name the sheet
wsNew.Name = c.Value
' copy template to new sheet
Sheets("FieldBase").Cells.Copy Destination:=wsNew.Range("A1").Cells
' Enter field name into FieldMaster for soils copy
Sheets("FieldMaster").Range("AA2").Value = wsNew.Name
' Copy base soil to Soils sheet
Range("SoilBase").Copy Sheets("Soils").Cells(Rows.Count, 1).End(xlUp)(2)
' enter sheet name in reference cell
wsNew.Range("B2").Value = wsNew.Name
' put field name into filter criteria to allow for alphanumerics
wsNew.Range("Q2").Formula = "=""=" & wsNew.Range("B2").Value & """"
' run advanced filter to get organic applications
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=wsNew.Range("Q1:Q2"), _
CopyToRange:=wsNew.Range("C11:E11"), _
Unique:=False
End If
Next
ws1.Select
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function