Advanced filter help

[austenr]

Im trying to filter records on a sheet with unique values for column D. Currently the code only shows the header on output. Its probably something simple but if anyone can point it out I would be appreciated.



Set wsMaster = ThisWorkbook.Worksheets("Summary-Schedule")
With wsMaster
Set rngFilter = .Range("D2", .Range("D" & .Rows.Count).End(xlUp))
Set rngResults = .Range("D1", .Range("N" & .Rows.Count).End(xlUp))


rngFilter.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUniques = .Range("D2", .Range("A" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)


If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilter.ShowAllData


End With


Here is the whole code. I've tracked it down to the following line. Don't know why it just copies the first row which is the hearers when the filtered sheet is header plus data rows.



rngResults.SpecialCells(xlCellTypeVisible).Copy Destination:=wbTemp.ActiveSheet.Range("A1")


Entire sub:



Sub PDFForEachMember()


Dim wsMaster As Worksheet
Dim wbTemp As Workbook
Dim OutApp As Object
Dim OutMail As Object
Dim rngFilter As Range 'filter range
Dim rngUniques As Range 'Unique Range
Dim cell As Range
Dim counter As Integer
Dim rngResults As Range 'filter range
Dim TempFilePath As String
Dim TempFileName As String
Dim vAddresses
Dim FileExtStr As String
Dim FileFormatNum As Long


If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
FileExtStr = ".xlsm": FileFormatNum = 52
End If


' change as necessary
TempFilePath = "C:\Users\arobinson1\Desktop\SRM Excel Data"


vAddresses = Sheets("Addresses").Range("SRMManagersAddress").Resize(, 2).Value


With Application
.ScreenUpdating = False
.EnableEvents = False
End With


Set OutApp = CreateObject("Outlook.Application")


Set wsMaster = ThisWorkbook.Worksheets("Summary-Schedule")
With wsMaster
Set rngFilter = .Range("D1", .Range("D" & .Rows.Count).End(xlUp))
Set rngResults = .Range("A1", .Range("N" & .Rows.Count).End(xlUp))


rngFilter.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUniques = .Range("D2", .Range("D" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)

If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilter.ShowAllData


End With


counter = 1


For Each cell In rngUniques


If vAddresses(counter, 1) Like "?*@?*.?*" And _
LCase(vAddresses(counter, 2)) = "yes" Then
Set wbTemp = Workbooks.Add(xlWBATWorksheet)
wbTemp.ActiveSheet.Name = cell.Value
rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value 'nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn
rngResults.SpecialCells(xlCellTypeVisible).Copy Destination:=wbTemp.ActiveSheet.Range("A1")


'TempFileName = TempFilePath & cell.Value & FileExtStr
TempFileName = TempFilePath & cell.Value & ".pdf"



Set OutMail = OutApp.CreateItem(0)




With wbTemp
'.SaveAs TempFileName, FileFormat:=FileFormatNum
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=TempFileName, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False


On Error Resume Next
With OutMail
.To = vAddresses(counter, 1)
.CC = ""
.BCC = ""
.Subject = "Travel exceptions"
.body = "Here are the travel detail for your team who booked thier travel less than 14 days in advance"
.Attachments.Add TempFileName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display

End With
On Error GoTo 0


.Close savechanges:=False


End With


Set OutMail = Nothing
End If
counter = counter + 1


Next cell


rngFilter.Parent.AutoFilterMode = False


End Sub

[Bob Phillips]

Can you post the workbook, struggling to envisage the data.

[austenr]

Here ya go Bob.

[austenr]

OK, I've got it almost. Two things.

1. The email loop tries to iterate an extra time giving a subscript out of range error.
2. The workbook created only picks up columns A:F, should be A:H.

Otherwise I am where I need to be. Here is the code:



Sub WorkbookForEachSRMMember()
'Reads each worksheet, stores them in a folder called C:\testing and emails each
'SET member with their own exceptions

Dim wsMaster As Worksheet
Dim wbTemp As Workbook
Dim OutApp As Object
Dim OutMail As Object
Dim rngFilter As Range 'filter range
Dim rngUniques As Range 'Unique Range
Dim cell As Range
Dim counter As Integer
Dim rngResults As Range 'filter range
Dim TempFilePath As String
Dim TempFileName As String
Dim vAddresses
Dim FileExtStr As String
Dim FileFormatNum As Long


If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2013
FileExtStr = ".xlsm": FileFormatNum = 52
End If


' change as necessary
TempFilePath = "C:\Users\arobinson1\Desktop\SRM Excel Data\"


vAddresses = Sheets("Addresses").Range("SRMManagersAddress").Resize(, 2).Value


With Application
.ScreenUpdating = False
.EnableEvents = False
End With


Set OutApp = CreateObject("Outlook.Application")


Set wsMaster = ThisWorkbook.Worksheets("Summary-Schedule")
With wsMaster
Set rngFilter = .Range("D1", .Range("D" & .Rows.Count).End(xlUp))
Set rngResults = .Range("A1", .Range("H" & .Rows.Count).End(xlUp))


rngFilter.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUniques = .Range("D2", .Range("D" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)


.ShowAllData


End With


counter = 1


For Each cell In rngUniques
If vAddresses(counter, 1) Like "?*@?*.?*" And _
LCase(vAddresses(counter, 2)) = "yes" Then
Set wbTemp = Workbooks.Add(xlWBATWorksheet)
wbTemp.ActiveSheet.Name = cell.Value
rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
rngResults.SpecialCells(xlCellTypeVisible).Copy Destination:=wbTemp.ActiveSheet.Range("A1")


TempFileName = TempFilePath & cell.Value & FileExtStr




Set OutMail = OutApp.CreateItem(0)




With wbTemp
.SaveAs TempFileName, FileFormat:=FileFormatNum


On Error Resume Next
With OutMail
.To = vAddresses(counter, 1)
.CC = ""
.BCC = ""
.Subject = "Travel exceptions"
.body = "Here are the travel detail for your team who booked thier travel less than 14 days in advance"
.Attachments.Add TempFileName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0


.Close savechanges:=False


End With


Set OutMail = Nothing
End If
counter = counter + 1


Next cell


rngFilter.Parent.AutoFilterMode = False


End Sub

[austenr]

Never mind, I got it. Hidden columns were messing it up.