Critério do Excel 2010 VBA AutoFilter e AutoFilter.Sort não aplicável

0

Estou tendo um longo tempo para aplicar os critérios do AutoFiltro, tanto na filtragem quanto na classificação. Eu estou tentando se livrar de linhas em branco e filtrar ao longo de vários critérios - simples, certo? Exceto que não funciona. Eu sinto que já tentei todos os hacks na net. Para se livrar de espaços em branco eu até tentei iterar através de cada linha, excluindo a linha se a primeira célula da linha estava em branco (ou "", ou TRIM (""), etc.) - era muito lenta, e ainda não funcionou. Eu tentei usar o método Range.Sort, que, tanto quanto eu posso dizer, funciona quase de forma idêntica ao método AutoFilter.Sort, exceto que ele não aparece quando você aperta o botão de menu Classificar . Métodos tentados de filtragem e classificação resultaram na ocultação de todo o intervalo de classificação / filtro ou na ocultação de nenhum deles. Com o código abaixo, os critérios AutoFilter e AutoFilter.Sort podem ser verificados por meio do menu suspenso e botão de classificação definidos corretamente, mas todo o intervalo de classificação / filtro (A1: O5000) está oculto e a lista não está classificada . Gravar uma macro de ativar manualmente um ou ambos mostra exatamente a mesma estrutura de código que estou usando.

Você vê qual poderia ser o problema?

Meu código depende de outra pasta de trabalho ( maintenance-record.xlsx ), então eu fiz o upload de ambos aqui:

  • link
  • [link removido - informações privadas]

VBA:

Option Explicit                                             ' checks variables

' Module-level variables

Dim Date_str, Name_str, Unit_str, Work_str, Impo_str, Kilo_str, Hour_str, Reso_str, Note_str As String
Dim Date_fmt, Name_fmt, Unit_fmt, Work_fmt, Impo_fmt, Kilo_fmt, Hour_fmt, Reso_fmt, Note_fmt As String
Dim Date_wid, Name_wid, Unit_wid, Work_wid, Impo_wid, Kilo_wid, Hour_wid, Reso_wid, Note_wid As Integer
Dim Date_col, Name_col, Unit_col, Work_col, Impo_col, Kilo_col, Hour_col, Reso_col, Note_col As Variant
Dim Range_ary, Ranges_ary As Variant
Dim Head_str As String, Head_fmt As String, Head_hgt As Integer

Dim CurrentWorksheet As Worksheet

Public Sub FormatAllSheets()
'
' FormatAllSheets Macro
'
' Recreates all worksheets.
' Formats column widths, data types, and freezes top row on all sheets except "rules".
'


    Application.ScreenUpdating = False              ' turn off screen updates

' Save current sheet and cell selection so we can go back to it when finished

    Dim ActSheet_str As String, ActRange_str As String
    ActSheet_str = ActiveSheet.Name
    ActRange_str = Selection.Address


' Delete existing sheets, except "rules"

    ThisWorkbook.Sheets("rules").Activate
    Application.DisplayAlerts = False               ' turn off notifications
    For Each CurrentWorksheet In Worksheets
        If CurrentWorksheet.Name <> "rules" Then CurrentWorksheet.Delete
    Next CurrentWorksheet
    Application.DisplayAlerts = True                ' turn on notifications


' Clear "rules", reset formulas

    Worksheets("rules").Range("A1:Z100").Delete
    Worksheets("rules").Range("A1:Z100").Formula = "=IF(ISBLANK(" & Chr(39) & "[maintenance-record.xlsx]rules" & Chr(39) & "!A1)," & Chr(34) & Chr(34) & "," & Chr(39) & "[maintenance-record.xlsx]rules" & Chr(39) & "!A1)"


' Create all sheets (blank), except "rules"

    ThisWorkbook.Sheets.Add.Name = "orig"
    ThisWorkbook.Sheets.Add.Name = "ALL"
    ThisWorkbook.Sheets.Add.Name = "CRIT"
    ThisWorkbook.Sheets.Add.Name = "NEW"


' Set font style Normal so subsequent character width actions are consistent

    With ThisWorkbook.Styles("Normal")
        .Font.Name = "Calibri"
        .Font.Size = "11"
    End With


' LOOP THROUGH EACH SHEET, except "rules"

    Call SetColumnData

    For Each CurrentWorksheet In Worksheets
        If CurrentWorksheet.Name <> "rules" Then
            CurrentWorksheet.Activate

            With CurrentWorksheet                               ' set column formats and widths
                For Each Range_ary In Ranges_ary
                    Range(Range_ary(0)).NumberFormat = Range_ary(1)
                    Range(Range_ary(0)).ColumnWidth = Range_ary(2)
                Next Range_ary

                Range(Head_str).RowHeight = Head_hgt            ' set headings height
                Range(Head_str).Font.Bold = True                ' set headings bold
                Range("E1,F1,J1,N1").Orientation = xlUpward     ' set some headings 90-deg

    ' Set the equations for all cells here, calling the various ranges (Select Case...)
                Dim Formula_str As String
                Select Case CurrentWorksheet.Name
                    Case Is = "orig"
                        Formula_str = "=IF(ISBLANK(" & Chr(39) & "[maintenance-record.xlsx]Sheet1" & Chr(39) & "!A1)," & Chr(34) & Chr(34) & "," & Chr(39) & "[maintenance-record.xlsx]Sheet1" & Chr(39) & "!A1)"
                    Case Is = "rules"
                        MsgBox "We shouldn't be iterating through 'rules'!!"
                    Case Is = "NEW"
                        Formula_str = "=IF(ROW(orig!A1)=1,orig!A1,IF(OR(ISERROR(orig!$A1),ISBLANK(orig!$A1),orig!$A1=" & Chr(34) & Chr(34) & ",orig!$J1=" & Chr(34) & "Y" & Chr(34) & "), TRIM(" & Chr(34) & Chr(34) & "),IF((TODAY()-orig!$A1)<rules!$B$9,orig!A1, TRIM(" & Chr(34) & Chr(34) & "))))"
                    Case Is = "CRIT"
                        Formula_str = "=IF(ROW(orig!A1)=1,orig!A1,IF(OR(ISERROR(orig!$A1),ISBLANK(orig!$A1),orig!$A1=" & Chr(34) & Chr(34) & ",orig!$J1=" & Chr(34) & "Y" & Chr(34) & "), TRIM(" & Chr(34) & Chr(34) & "),IF(OR(AND(orig!$N1=" & Chr(34) & "HIGH" & Chr(34) & ",(TODAY()-orig!$A1)>rules!$B$6),AND(orig!$N1=" & Chr(34) & "MED" & Chr(34) & ",(TODAY()-orig!$A1)>rules!$B$5),AND(orig!$N1=" & Chr(34) & "LOW" & Chr(34) & ",(TODAY()-orig!$A1)>rules!$B$4),AND(orig!$N1=" & Chr(34) & "WAIT" & Chr(34) & ",(TODAY()-orig!$A1)>rules!$B$3)),orig!A1, TRIM(" & Chr(34) & Chr(34) & "))))"
                    Case Is = "ALL"
                        Formula_str = "=IF(ROW(orig!A1)=1,orig!A1,IF(OR(ISERROR(orig!$A1),ISBLANK(orig!$A1),orig!$A1=" & Chr(34) & Chr(34) & ",orig!$J1=" & Chr(34) & "Y" & Chr(34) & "), TRIM(" & Chr(34) & Chr(34) & "),orig!A1))"
                    Case Else
                        Formula_str = ""
                End Select
                Range("A1:O5000").Formula = Formula_str

    ' Set headings text
                Range("A1:O1").Value = Array( _
                    "report date", _
                    "reported by", _
                    "unit", _
                    "work required / work completed", _
                    "importance - original", _
                    "importance - supervisor", _
                    "work date", _
                    "kilometers", _
                    "hours", _
                    "Resolved?", _
                    "assigned to", _
                    "Shop Manager review date", _
                    "notes", _
                    "importance - overall", _
                    "importance - numeric" _
                )

    ' Format all cells except the headings
                With Range("A2:O5000")
                    .WrapText = True
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = False
                    .Rows.AutoFit
                    .VerticalAlignment = xlBottom
                End With

    ' Set custom sorting for each page, except "rules"
'                .AutoFilter.Sort.SortFields.Clear
'                .Sort.SortFields.Clear
'                .Sort.SetRange Range("A1:O5000")
'                Select Case CurrentWorksheet.Name
'                    Case Is = "NEW"
'                        .Sort.SortFields.Add Key:=Range("A2:A5000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
'                        .Sort.SortFields.Add Key:=Range("C2:C5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'                        .Sort.SortFields.Add Key:=Range("O2:O5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'                        .Sort.SortFields.Add Key:=Range("B2:B5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'                    Case Is = "CRIT"
'                        .Sort.SortFields.Add Key:=Range("O2:O5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'                        .Sort.SortFields.Add Key:=Range("C2:C5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'                        .Sort.SortFields.Add Key:=Range("A2:A5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'                    Case Is = "ALL"
'                        .Sort.SortFields.Add Key:=Range("C2:C5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'                        .Sort.SortFields.Add Key:=Range("O2:O5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'                        .Sort.SortFields.Add Key:=Range("A2:A5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'                End Select
'                .Sort.Header = xlYes
'                .Sort.MatchCase = False
'                .Sort.Orientation = xlTopToBottom
'                .Sort.SortMethod = xlPinYin
'                .Sort.Apply

'    ' Set custom sorting for each page, except "rules", using AutoFilter
                .AutoFilterMode = False                 ' clear previous filters... shouldn't make a difference
                .Range("A1:O1").AutoFilter
                If .Name = "NEW" Then
                        .AutoFilter.Sort.SortFields.Add Key:=Range("A2:A5000"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
                        .AutoFilter.Sort.SortFields.Add Key:=Range("C2:C5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                        .AutoFilter.Sort.SortFields.Add Key:=Range("O2:O5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                        .AutoFilter.Sort.SortFields.Add Key:=Range("B2:B5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                ElseIf .Name = "CRIT" Then
                        .AutoFilter.Sort.SortFields.Add Key:=Range("O2:O5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                        .AutoFilter.Sort.SortFields.Add Key:=Range("C2:C5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                        .AutoFilter.Sort.SortFields.Add Key:=Range("A2:A5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                ElseIf .Name = "ALL" Then
                        .AutoFilter.Sort.SortFields.Add Key:=Range("C2:C5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                        .AutoFilter.Sort.SortFields.Add Key:=Range("O2:O5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                        .AutoFilter.Sort.SortFields.Add Key:=Range("A2:A5000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                Else
                End If
                .AutoFilter.Sort.Header = xlYes
                .AutoFilter.Sort.MatchCase = False
                .AutoFilter.Sort.Orientation = xlTopToBottom
                .AutoFilter.Sort.SortMethod = xlPinYin
                .AutoFilter.Sort.Apply

    ' Filter out blank rows for each page, except "rules"
                .Range("A1:O1").AutoFilter Field:=1, Criteria1:="<>"

            End With

        End If
    Next CurrentWorksheet


    Application.ScreenUpdating = True              ' turn on screen updates


' Go back to the original sheet and selection

    Worksheets(ActSheet_str).Activate
    Worksheets(ActSheet_str).Range(ActRange_str).Select


    MsgBox "Finished."

End Sub

Sub SetColumnData()

'Define column formats and ranges for all sheets, except "rules"
    Date_str = "A:A,G:G,L:L"            ' column range
    Date_fmt = "[$-409]mmmm d, yyyy;@"  ' custom number format
    Date_wid = 19                       ' width in characters (zeroes in font style Normal)
    Name_str = "B:B,K:K"
    Name_fmt = "@"
    Name_wid = 18
    Unit_str = "C:C"
    Unit_wid = 6
    Work_str = "D:D"
    Work_wid = 66
    Impo_str = "E:E,F:F,N:N"
    Impo_wid = 5
    Kilo_str = "H:H"
    Kilo_wid = 10
    Hour_str = "I:I"
    Hour_wid = 9
    Reso_str = "J:J"
    Reso_wid = 4
    Note_str = "M:M"
    Note_wid = 50
    Head_str = "A1:N1"
    Head_hgt = 120

    Date_col = Array(Date_str, Date_fmt, Date_wid)
    Name_col = Array(Name_str, Name_fmt, Name_wid)
    Unit_col = Array(Unit_str, Unit_fmt, Unit_wid)
    Work_col = Array(Work_str, Work_fmt, Work_wid)
    Impo_col = Array(Impo_str, Impo_fmt, Impo_wid)
    Kilo_col = Array(Kilo_str, Kilo_fmt, Kilo_wid)
    Hour_col = Array(Hour_str, Hour_fmt, Hour_wid)
    Reso_col = Array(Reso_str, Reso_fmt, Reso_wid)
    Note_col = Array(Note_str, Note_fmt, Note_wid)

    Ranges_ary = Array(Date_col, Name_col, Unit_col, Work_col, Impo_col, Kilo_col, Hour_col, Reso_col, Note_col)

End Sub

Se você está curioso, este é um sistema de rastreamento de manutenção que desenvolvi para uma pequena empresa de caminhões e transporte. Essas folhas precisam ser à prova de adulteração, pois até uma dúzia de novatos de computador as usam diariamente, então codifiquei intensamente a formatação, a filtragem, a classificação e as equações nos scripts vba ocultos. Está longe de ser perfeito, mas funciona principalmente. Sou apenas um supervisor que realmente precisava de uma solução para equipamentos negligenciados.

    
por tyblu 28.12.2015 / 03:52

0 respostas