Solved: Filtering multiple worksheets based on master worksheet

[leannika]

I am writing this in the hopes that someone can help me. I am fairly new in vba experience but am learning quickly. I am trying to use bits and pieces of various codes on the web and am running into stumbling blocks left and right. Basically I have a spreadsheet with 7 worksheets. The first is the master mailing list (with simply customer ID and email address). The other spreadsheets are 6 reports. The first column in each of the 6 spreadsheets is the customer ID. I am looking for a code that, for each customer ID on the master mailing list, will go through the 6 spreadsheets, filter them based on the customer ID, copy the 6 spreadsheets into a new workbook, and either email (via a vlookup to the email address on the master mailling list) or save. It will then loop through all of the customer IDs on the master mailing list. Some of the customer IDs will not have any data in any of the 6 spreadsheets, but I would still like them to get a blank spreadsheet (with headers).

Any help would be extremely appreciated.

[leannika]

I found some code that did mostly what I was looking for and I was able to piece together a few additions and came up with the following to do what I was looking for. In my example above, I had 6 spreadsheets that needed to be copied. In the interest of time and space, the example below has only 4. Rather than save, the code allows for automatic email.

Sub SEND_Parsed_Workbook
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim eng As Range
Dim png As Range
Dim nng As Range
Dim tng As Range
Dim wb1 As Worksheet
Dim wb2 As Worksheet
Dim wb3 As Worksheet
Dim wb4 As Worksheet
Dim Ash As Worksheet
Dim Tsh As Worksheet
Dim Esh As Worksheet
Dim Psh As Worksheet
Dim Nsh As Worksheet
Dim Cws As Worksheet
Dim WWs As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim NewWB As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Set filter sheet,
Set Ash = Worksheets("MailInfo")
'Set filter range and filter column (column with names)
Set FilterRange = Ash.Range("A1:AA" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in column A
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
'Look for the mail address in the MailInfo worksheet
mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("Mailinfo").Range("A1:B" & _
Worksheets("Mailinfo").Rows.Count), 2, False)
On Error GoTo 0
If mailAddress <> "" Then

'Parsing First Worksheet (Sheet1)
Set Psh = Worksheets("Sheet1")

Set FilterRange = Psh.Range("A1:AA" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in column A

With Psh
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
End With

With Psh.AutoFilter.Range
On Error Resume Next
Set png = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With

'Parse Second Worksheet
Set Esh = Worksheets("Sheet2")

Set FilterRange = Esh.Range("A1:AA" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in column A

With Esh
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
End With

With Esh.AutoFilter.Range
On Error Resume Next
Set eng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With

'Parse third worksheet
Set Tsh = Worksheets("Sheet3")

Set FilterRange = Tsh.Range("A1:AA" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in column A

With Tsh
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
End With

With Tsh.AutoFilter.Range
On Error Resume Next
Set tng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With

'Parse 4th worksheet
Set Nsh = Worksheets("Sheet4")

Set FilterRange = Nsh.Range("A1:AA" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in column A

With Nsh
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
End With

With Nsh.AutoFilter.Range
On Error Resume Next
Set nng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With


'Create new workbook and add worksheets

Set NewWB = Workbooks.Add(xlWBATWorksheet)
Worksheets.Add().Name = "New Sheet 1"
Worksheets.Add().Name = "New Sheet 2"
Worksheets.Add().Name = "New Sheet 3"
Worksheets.Add().Name = "New Sheet 4"
Set wb1 = Worksheets("New Sheet 1")
Set wb2 = Worksheets("New Sheet 2")
Set wb3 = Worksheets("New Sheet 3")
Set wb4 = Worksheets("New Sheet 4")


'Copy the visible data in a new workbook and PASSWORD PROTECT
png.Copy
With wb1
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End With

eng.Copy
With wb2
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
'.Cells(2).Select
Application.CutCopyMode = False

End With

tng.Copy
With wb3
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End With

nng.Copy
With wb4
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
ActiveWorkbook.Password = "thisisthepassword"
End With

'Create a file name
TempFilePath = Environ$("temp") & "\"
TempFileName = "DATA & " " & Format(Now, "dd-mmm-yy h-mm-ss")
If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
FileExtStr = ".xlsx": FileFormatNum = 51
End If
'Save, Mail, Close and Delete the file
Set OutMail = OutApp.CreateItem(0)
With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = mailAddress
.Subject = "This is the subject"
.Attachments.Add NewWB.FullName
.Body = "This is the body"
.Display 'Or use Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Tsh.AutoFilterMode = False
Psh.AutoFilterMode = False
Nsh.AutoFilterMode = False


Next Rnum
End If
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub