Consulting

Results 1 to 5 of 5

Thread: Advanced filter help

  1. #1
    Moderator VBAX Master austenr's Avatar
    Joined
    Sep 2004
    Location
    Maine
    Posts
    2,033
    Location

    Advanced filter help

    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
    Peace of mind is found in some of the strangest places.

  2. #2
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,453
    Location
    Can you post the workbook, struggling to envisage the data.
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  3. #3
    Moderator VBAX Master austenr's Avatar
    Joined
    Sep 2004
    Location
    Maine
    Posts
    2,033
    Location
    Here ya go Bob.
    Attached Files Attached Files
    Peace of mind is found in some of the strangest places.

  4. #4
    Moderator VBAX Master austenr's Avatar
    Joined
    Sep 2004
    Location
    Maine
    Posts
    2,033
    Location
    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
    Peace of mind is found in some of the strangest places.

  5. #5
    Moderator VBAX Master austenr's Avatar
    Joined
    Sep 2004
    Location
    Maine
    Posts
    2,033
    Location
    Never mind, I got it. Hidden columns were messing it up.
    Peace of mind is found in some of the strangest places.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •