VBA to loop code based on list

[Legacy 379249]

Hello!

I am working in Excel 2010 on a Windows 7. I have a set of data that I am trying to filter by each value in a column within the data set, save it as a new spreadsheet, and then email to a specific individual. I pulled out all of the values that I need to filter on and created a new tab called Cost Centers, so that I can easily reference the cell that will dictate what the AutoFilter in my macro should be. I know that is probably not the most efficient way of doing it however.

I have some basic pieces of VBA that I put together to filter a set of data (Equipment Data) based on a value (A2) in another tab (Cost Centers). Once filtered, the macro then copies and pastes the data into a new tab, names it, prompts for a save, and then attaches the file to an email. I have tested this and it all works great, but just one time.

In all, I have to repeat this process almost 150 times and it doesn't seem feasible to copy and paste the code 150 times and change the cell that I'm referencing to A3, and then A4, etc. Also when I did try to do this I was receiving a "Duplicate declaration in current scope error because of "Dim rng" and from what I have been seeing online I would have to rename each one of those as well.

Is there a way for me to repeat the code but change the one cell that I'm referencing for the filter so I can run the macro once and it will filter, save, and attach to an email for every value in my Cost Centers list?

Below is the VBA:

Sub FilterSaveEmail1()
'
' AutoFilter the raw data based on the cost center tab
'

'
With Worksheets("Data")
.AutoFilterMode = False
With .Range("Equipment_Data")
.AutoFilter
.AutoFilter Field:=21, Criteria1:=Worksheets("Cost Centers").Range("A3").Value
End With
End With

Range("A:AF").Select
Dim rng As Range
Set rng = Application.Intersect(ActiveSheet.UsedRange, Range("A:AF"))
rng.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Dim WS As Worksheet
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Select
ActiveSheet.Paste
ActiveSheet.Name = "Equipment In NA Space"
'
' SaveWorksheet and send file as email attachment
'

'
Sheets("Equipment in NA Space").Select
Sheets("Equipment in NA Space").Move
Sheets("Equipment in NA Space").Select

Dim fname, fpath
fname = InputBox("enter a name")
fname = fname & ".xlsx"
fpath = "K:\FINRPTG\PLANT\Plant16\FY16 URSpace\FY2016 URSpace reports"
ActiveWorkbook.SaveAs fpath & fname

'PURPOSE: Create email message with only Selected Worksheets attached
'SOURCE: Squarespace - Claim This Domain

Dim SourceWB As Workbook
Dim DestinWB As Workbook
Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim TempFileName As Variant
Dim ExternalLinks As Variant
Dim TempFilePath As String
Dim FileExtStr As String
Dim DefaultName As String
Dim UserAnswer As Long
Dim x As Long

'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False

'Copy only selected sheets into new workbook
Set SourceWB = ActiveWorkbook
SourceWB.Windows(1).SelectedSheets.Copy
Set DestinWB = ActiveWorkbook

'Check for macro code residing in
If Val(Application.Version) >= 12 Then
If SourceWB.FileFormat = 51 And SourceWB.HasVBProject = True Then
UserAnswer = MsgBox("There was VBA code found in this xlsx file. " & _
"If you proceed the VBA code will not be included in your email attachment. " & _
"Do you wish to proceed?", vbYesNo, "VBA Code Found!")

'Handle if user cancels
If UserAnswer = vbNo Then
DestinWB.Close SaveChanges:=False
GoTo ExitSub
End If

End If
End If

'Determine Temporary File Path
TempFilePath = Environ$("temp") & "\"

'Determine Default File Name for InputBox
If SourceWB.Saved Then
DefaultName = Left(SourceWB.Name, InStrRev(SourceWB.Name, ".") - 1)
Else
DefaultName = SourceWB.Name
End If

'Ask user for a file name
TempFileName = Application.InputBox("What would you like to name your attachment? (No Special Characters!)", _
"File Name", Type:=2, Default:=DefaultName)

If TempFileName = False Then GoTo ExitSub 'Handle if user cancels

'Determine File Extension
If SourceWB.Saved = True Then
FileExtStr = "." & LCase(Right(SourceWB.Name, Len(SourceWB.Name) - InStrRev(SourceWB.Name, ".", , 1)))
Else
FileExtStr = ".xlsx"
End If

'Break External Links
ExternalLinks = DestinWB.LinkSources(Type:=xlLinkTypeExcelLinks)

'Loop Through each External Link in ActiveWorkbook and Break it
On Error Resume Next
For x = 1 To UBound(ExternalLinks)
DestinWB.BreakLink Name:=ExternalLinks(x), Type:=xlLinkTypeExcelLinks
Next x
On Error GoTo 0

'Save Temporary Workbook
DestinWB.SaveCopyAs TempFilePath & TempFileName & FileExtStr

'Create Instance of Outlook
On Error Resume Next
Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if Outlook is already open
Err.Clear
If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(class:="Outlook.Application") 'If not, open Outlook

If Err.Number = 429 Then
MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
GoTo ExitSub
End If
On Error GoTo 0

'Create a new email message
Set OutlookMessage = OutlookApp.CreateItem(0)

'Create Outlook email with attachment
On Error Resume Next
With OutlookMessage
.To = ""
.CC = ""
.BCC = ""
.Subject = TempFileName
.Body = "Please see attached." & vbNewLine & vbNewLine & "Chris"
.Attachments.Add TempFilePath & TempFileName & FileExtStr
.Display
End With
On Error GoTo 0

'Close & Delete the temporary file
DestinWB.Close SaveChanges:=False
Kill TempFilePath & TempFileName & FileExtStr

'Clear Memory
Set OutlookMessage = Nothing
Set OutlookApp = Nothing

'Optimize Code
ExitSub:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub