Filtre élaboré complexe

Public Sub DAOOpenISAMDatabase()
    Dim db          As DAO.Database
    Dim rst         As DAO.Recordset
    Dim wbBook      As Workbook
    Dim intChamp    As Integer
    Dim intN        As Integer
    Dim strSQL      As String
 
    On Error GoTo Err_
 
    ' création du classeur qui va recevoir le contenu du recordset
    Set wbBook = Workbooks.Add
    Windows.Arrange xlArrangeStyleHorizontal
 
    ' ouverture de la base Excel en lecture seule
    Set db = DBEngine.OpenDatabase("C:\Document\Mon Fichier.xls", True, True, "Excel 8.0;")
 
    '***************************************************************************************************************
    '***************************************************************************************************************
    ' création du recordset
 
    ' la requête doit bien sûr être adaptée à ta base et à tes besoins
    strSQL = "SELECT RiskFactorName FROM Base WHERE Activity='GAS' AND RiskFactorThreshold IS NOT NULL"
 
    ' ATTENTION ! ce type de RecordSet ne permet que la lecture
    Set rst = db.OpenRecordset(strSQL, dbOpenForwardOnly, dbReadOnly)
    '***************************************************************************************************************
    '***************************************************************************************************************
 
    ' écrire la requête dans la feuille Excel
    Range("A1").Value = strSQL
    Range("A1").Font.ColorIndex = 5
 
    ' écrire le nom des champs du RS
    intChamp = rst.Fields.Count
    For intN = 0 To intChamp - 1
        Cells(3, 1 + intN).Value = rst.Fields(intN).Name
    Next
    With Rows(3)
        .Font.Bold = True
        .Cells.HorizontalAlignment = xlHAlignCenter
    End With
 
    Range("A4").Select
    ActiveWindow.FreezePanes = True
 
    ' écrire les valeurs du RS
    Do Until rst.EOF
        For intN = 0 To intChamp - 1
            Cells(ActiveCell.Row, 1 + intN).Value = rst.Fields(intN).Value
        Next
        ActiveCell.Offset(1, 0).Select
        rst.MoveNext
    Loop
 
    ' fermer le RS
    rst.Close
    ' fermer la base
    db.Close
    'wbBook.Close savechanges:=False
    'wbBook.Saved = True
 
    Set db = Nothing: Set rst = Nothing: Set wbBook = Nothing
    Exit Sub
 
Err_:
    Debug.Print Err.Number, Err.Description
    Stop
    Resume
End Sub

Sub Recherche()
Dim i As Integer     ‘ type de la donnée
i = 1500

Application.ScreenUpdating = False
On Error Resume Next
Range("A11:A" & i).RowHeight = 12.75         ‘ajuster toutes les lignes à la même hauteur
On Error GoTo 0

Crit = Range("A4")  ' critère centre courrier
If Crit <> "" Then
  For Each o In Range("A11:A" & i)
    If o <> Crit Then o.RowHeight = 0
  Next
End If

Crit = Range("B4") ' critère code action
If Crit <> "" Then
  For Each o In Range("E11:E" & i)
    If o.RowHeight > 0 And o <> Crit Then o.RowHeight = 0
  Next
End If

Crit = Range("C4")  ' critère type (charge, immo)
If Crit <> "" Then
  For Each o In Range("K11:K" & i)
    If o.RowHeight > 0 And o <> Crit Then o.RowHeight = 0
  Next
End If

Crit = Range("a7")   ' critère rubrique
If Crit <> "" Then
  For Each o In Range("H11:H" & i)
    If o.RowHeight > 0 And o <> Crit Then o.RowHeight = 0
  Next
End If

Crit = Range("b7")   ' critère sous-rubrique
If Crit <> "" Then
  For Each o In Range("i11:i" & i)
    If o.RowHeight > 0 And o <> Crit Then o.RowHeight = 0
  Next
End If

Crit = Range("c7")    ' critère libellé
If Crit <> "" Then
  For Each o In Range("j11:j" & i)
    If o.RowHeight > 0 And o <> Crit Then o.RowHeight = 0

Next
End If
End Sub