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:
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.