Looping a pivot filter change & sending via email

Hi all

First time posting, i'm wondering if anyone can spot where i am going wrong.

I have a pivot table with info on a number of buildings. The page filter is set up to select each building in turn. I also have a list of personel on a different tab with their email adresses.

What i am trying to do is:

Filter the pivot table one building at a time, copy the filtered pivot into a new workbook, save the workbook as the building name, open a new email, attach the saved workbook, name the subject as the building name, and email the workbook to the associated email adresses.

I then want to loop the macro to work its way down the list of sites, sending emails to the relevant personnel.

By probably blind luck, the macro i have created works all the way through, but fails at the first sign of looping. Can anyone help please?





Sub Macro1()
'
Dim x As Integer

Sheets("Email").Select
' Set numrows = number of rows of data.
NumRows = Range("b2", Range("b2").End(xlDown)).Rows.Count
' Select cell a1.
Range("b2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows

Selection.Copy
Sheets("Fault Report").Select
Range("F1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Sheets("Fault Report").PivotTables("PivotTable1").PivotFields("Site").CurrentPage _
= Sheets("Fault Report").Range("F1").Value

Sheets("Fault Report").Select
Selection.Copy
Application.CutCopyMode = False
Sheets("Fault Report").Select
Sheets("Fault Report").Copy

ChDir "C:\Documents and Settings\firstname.lastname\Desktop"

FolderPath = "C:\Documents and Settings\firstname.lastname\Desktop\"
SavePath = FolderPath & Sheets("Fault Report").Range("F1").Text
ActiveWorkbook.SaveAs Filename:=SavePath, FileFormat:=xlNormal

Dim OL As Object

Dim EmailItem As Object
Dim Doc As Workbook
Application.ScreenUpdating = False

Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)

Set Doc = ActiveWorkbook

With EmailItem

.Subject = Sheets("Fault Report").Range("F1").Value

.To = "[email protected];"
.Importance = olImportanceNormal 'Or olImprotanceHigh Or olImprotanceLow
.Attachments.Add Doc.FullName
.Display

' .Send

ActiveWorkbook.Close

End With

Application.ScreenUpdating = True

Set Doc = Nothing

Set OL = Nothing

Set EmailItem = Nothing

' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next

End Sub