Sub LignesMultiMotsClasseur()
Dim WB As Workbook
Dim S As Worksheet
Dim rep
Dim R As Range
Dim Titres
Dim var
Dim dep&
Dim g&
Dim h&
Dim i&
Dim j&
Dim k&
Dim cpt&
Dim T()
Dim A$
Dim B$()
On Error GoTo Erreur
Titres = Array("Mot recherché", "Feuille", "N° de ligne")
rep = Application.InputBox( _
"Tapez le mot à rechercher" & vbCrLf & vbCrLf & _
"Si plusieurs mots, les séparer par un antislash ( \ )", _
"Lignes contenant les mots recherchés")
If rep = False Or rep = "" Then Exit Sub
A$ = LCase(rep)
Do Until Left(A$, 1) <> "\" And Left(A$, 1) <> Space(1)
A$ = Mid(A$, 2)
Loop
Do Until Right(A$, 1) <> "\" And Right(A$, 1) <> Space(1)
A$ = Mid(A$, 1, Len(A$) - 1)
Loop
If InStr(1, A$, "\") = 0 Then
ReDim B$(1 To 1)
B$(1) = A$
Else
Do Until A$ = ""
If Right(A$, 1) <> "\" Then A$ = A$ & "\"
i& = i& + 1
ReDim Preserve B$(1 To i&)
B$(i&) = Mid(A$, 1, InStr(1, A$, "\") - 1)
A$ = Trim(Mid(A$, Len(B$(i&)) + 2))
Do Until Left(A$, 1) <> "\" And Left(A$, 1) <> Space(1)
A$ = Mid(A$, 2)
Loop
B$(i&) = Trim(B$(i&))
Loop
End If
Set WB = ActiveWorkbook
For h& = 1 To WB.Worksheets.Count
Set S = WB.Worksheets(h&)
Set R = S.UsedRange
dep& = R.Row
var = R
If R.Columns.Count > 253 Then
MsgBox "La feuille ''" & S.Name & _
"'' ne peut être traitée car elle comporte plus de 253 colonnes."
Else
If Not IsEmpty(var) Then
For g& = 1 To UBound(B$)
For i& = 1 To UBound(var, 1)
For j& = 1 To UBound(var, 2)
A$ = LCase(Trim(var(i&, j&)))
If InStr(1, A$, B$(g&)) > 0 Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 253, 1 To cpt&)
T(1, cpt&) = B$(g&)
T(2, cpt&) = S.Name
T(3, cpt&) = i& + dep& - 1
For k& = 1 To UBound(var, 2)
T(k& + 3, cpt&) = var(i&, k&)
Next k&
Exit For
End If
Next j&
Next i&
Next g&
End If
End If
Next h&
If cpt& = 0 Then
A$ = ""
For i& = 1 To UBound(B$)
A$ = A$ & vbCrLf & B$(i&)
Next i&
MsgBox "Aucune occurence de" & A$ & vbCrLf & "n'a été trouvée."
Exit Sub
Else
Application.ScreenUpdating = False
Set S = Sheets.Add(before:=ActiveSheet)
Set R = S.Range(S.Cells(2, 1), S.Cells(UBound(T, 2) + 1, UBound(T, 1)))
R = Application.WorksheetFunction.Transpose(T)
Set R = S.Range(S.Cells(1, 1), S.Cells(1, UBound(Titres) + 1))
R = Titres
R.HorizontalAlignment = xlCenter
R.Font.Bold = True
R.Interior.ColorIndex = 40
S.Cells.Columns.AutoFit
End If
Erreur:
Application.ScreenUpdating = True
If Err <> 0 Then MsgBox "Erreur : " & Err.Number & vbCrLf & Err.Description
End Sub