1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91
| Sub Count_Worksheet_Lines()
'declaration
Dim Fltr As Filter
Dim AutoFilterSettings() As String
Dim NumOfCriteria As Integer
Dim NumOfItem As Integer
Dim MaxCriteria As Integer
Dim CurrentFilter As Integer
Dim Veriftab As Variant
Dim NewCriteria() As String
Dim i As Integer, j As Integer
Dim WS As Worksheet
Set WS = ThisWorkbook.Sheets("Sheet1")
Dim NumOfLine As Integer
'init
MaxCriteria = 0
CurrentFilter = 1
NumOfLine = 0
'Check if autofilter is activated and saved settings
If WS.AutoFilterMode = True Then
'Count item
NumOfItem = WS.AutoFilter.Filters.Count
'MsgBox NumOfItem
ReDim AutoFilterSettings(1 To NumOfItem, 1 To 2)
For Each Fltr In WS.AutoFilter.Filters
If Fltr.On Then
NumOfCriteria = Fltr.Count
If NumOfCriteria > MaxCriteria Then
MaxCriteria = NumOfCriteria
ReDim Preserve AutoFilterSettings(1 To NumOfItem, 1 To MaxCriteria + 1)
End If
AutoFilterSettings(CurrentFilter, 1) = NumOfCriteria
'MsgBox NumOfCriteria
If NumOfCriteria > 2 Then
For i = 1 To NumOfCriteria
AutoFilterSettings(CurrentFilter, i + 1) = Fltr.Criteria1(i)
Next i
ElseIf NumOfCriteria = 2 Then
AutoFilterSettings(CurrentFilter, 2) = Fltr.Criteria1
AutoFilterSettings(CurrentFilter, 3) = Fltr.Criteria2
ElseIf NumOfCriteria = 1 Then
AutoFilterSettings(CurrentFilter, 2) = Fltr.Criteria1
End If
Else
AutoFilterSettings(CurrentFilter, 1) = 0
End If
CurrentFilter = CurrentFilter + 1
Next Fltr
End If
'desactivate autofilter
If WS.AutoFilterMode = True Then
WS.AutoFilterMode = False
End If
'count lines
NumOfLine = WS.Range("F1").End(xlDown).Row
MsgBox NumOfLine
'check if Autofiltersetings is empty, if yes exit sub
On Error Resume Next
Veriftab = UBound(AutoFilterSettings)
On Error GoTo 0
If IsEmpty(Veriftab) Then Exit Sub
'Activate autofilter
WS.Range("A1").AutoFilter
'restore previous autofilter
For i = 1 To UBound(AutoFilterSettings, 1)
If AutoFilterSettings(i, 1) = 1 Then
WS.Range("A1").AutoFilter Field:=i, Criteria1:=AutoFilterSettings(i, 2)
ElseIf AutoFilterSettings(i, 1) = 2 Then
WS.Range("A1").AutoFilter Field:=i, Criteria1:=AutoFilterSettings(i, 2), Operator:=xlOr, Criteria2:=AutoFilterSettings(i, 3)
ElseIf CDbl(AutoFilterSettings(i, 1)) > 2 Then
ReDim NewCriteria(AutoFilterSettings(i, 1))
For j = 1 To AutoFilterSettings(i, 1)
NewCriteria(j) = AutoFilterSettings(i, j + 1)
Next j
WS.Range("A1").AutoFilter Field:=i, Criteria1:=NewCriteria, Operator:=xlFilterValues
End If
Next i
End Sub |
Partager