Bonjour,
La macro ci dessous permet de faire un tri en fonction des mots demandés et de les reporter vers une nouvelle feuille.
Le soucis, c'est lorsque, je prends pour test un document avec 5 colonnes et 10 lignes.
Par avance merci pour votre aide.
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
La macro ci dessous permet de faire un tri en fonction des mots demandés et de les reporter vers une nouvelle feuille.
Le soucis, c'est lorsque, je prends pour test un document avec 5 colonnes et 10 lignes.
Par avance merci pour votre aide.
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
