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
| Private Sub CommandButton1_Click()
Dim Tbl() As Variant
Dim PlageDeRecherche As Range
Dim Trouve As Range
Dim I As Long
Dim Adr As String
Dim mot, NOM As String
Dim dico As Object
lettrecolonnejournal = journal.Text
valeurjournal = Asc(UCase(lettrecolonnejournal)) - 64 'Demande première colonne
lettrecolonneecriture = ecriture.Text
valeurecriture = Asc(UCase(lettrecolonneecriture)) - 64 'Demande deuxième colonne
Application.DisplayAlerts = False 'Gain de temps lors de l'execution
NOM = UCase(TextBox1.Value)'Mise en majuscule
If FeuilleExiste(NOM) = True Then 'Module pour vérifier la présence de la feuille
MsgBox ("La feuille " & NOM & " existe déja !")
GoTo line2
End If
Sheets.Add.Name = NOM 'Ajout de la feuille
line2:
mot = "*" & TextBox1.Value & "*" 'les étoiles pour trouver dans les cellules
With Worksheets("FEC"):
Set Plage = Union(.Range(.Cells(2, valeurjournal), .Cells(.Rows.Count, valeurjournal)), .Range(.Cells(2, valeurecriture), .Cells(.Rows.Count, valeurecriture))): End With ' recherche dans les deux colonnes
Set Trouve = Plage.Find(mot, LookIn:=xlValues)
'PlageDeRecherche.Find(mot, , xlValues, xlWhole)
If Not Trouve Is Nothing Then
Adr = Trouve.Address
Do
I = I + 1
ReDim Preserve Tbl(I)
Tbl(I) = Trouve.Row
Set Trouve = Plage.FindNext(Trouve)
Loop While Trouve.Address <> Adr
'Attention, si la ligne est cachée, la valeur ne sera pas trouvée !
For Z = 1 To UBound(Tb1) '' Ça plante et me mets incompatibilité de type...
Sheets("FEC").Rows(Tbl(I)).EntireRow.Copy
'Sheets("FEC").Cells(ligne, 1).EntireRow.Copy
Sheets(mot).Select
a = a + 1
Sheets(mot).Cells(a, 1).EntireRow.Select
ActiveSheet.Paste
Next
End If
End Sub |
Partager