Sub Ajouter()
Dim nom$, lig As Variant
nom = [C5]
With Feuil3
lig = Application.Match(nom, .[B:B], 0)
If IsNumeric(lig) Then _
If MsgBox("Le nom '" & nom & "' est déjà enregistré, faut-il continuer ?", 52, "Doublon !") = 7 Then Exit Sub
lig = .[A5].CurrentRegion.Rows.Count + 5
[C4] = Application.Max(.[A:A]) + 1 'incrémente le numéro
With .Cells(lig, 1).Resize(, 7)
.Value = Application.Transpose([C4:C10]) 'transfert
.Borders.Weight = xlThin 'bordures
End With
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x$, tablo, i&, j%, n&, k%
If Intersect(Target, [E3]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Range("G4:M" & Rows.Count).Delete xlUp 'RAZ
x = "*" & LCase([E3].Text) & "*"
If x = "**" Then Exit Sub
tablo = Feuil3.[A5].CurrentRegion.Offset(1) 'matrice, plus rapide
For i = 1 To UBound(tablo)
For j = 1 To 7
If LCase(tablo(i, j)) Like x Then
n = n + 1
For k = 1 To 7
tablo(n, k) = tablo(i, k)
Next k
Exit For
End If
Next j, i
'---restitution---
With [G4].Resize(n, 7)
.Value = tablo
.Borders.Weight = xlThin 'bordures
End With
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim r As Range, i As Variant
Set r = Intersect(Target.EntireRow, Range("G4:M" & Rows.Count))
If r Is Nothing Then Exit Sub
Cancel = True
i = Application.Match(r(1), Feuil3.[A:A], 0)
If IsNumeric(i) Then r.Copy Feuil3.Range("A" & i) 'transfert
r.Delete xlUp 'suppression de la ligne
End Sub
merci beaucoup bon travailBonjour kahlouch,
Voyez le fichier joint et le code de la feuille "AA" :
A+Code:Sub Ajouter() Dim lig& lig = Feuil3.Cells(5, 1).CurrentRegion.Rows.Count + 5 Feuil3.Cells(lig, 1).Resize(, 7) = Application.Transpose(Range("C4:C10")) End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim x$, lig&, c As Range, i& If Intersect(Target, [E3]) Is Nothing Then Exit Sub Application.ScreenUpdating = False Range("G4:M" & Rows.Count).Delete xlUp 'RAZ x = "*" & LCase([E3].Text) & "*" If x = "**" Then Exit Sub lig = 4 With Feuil3.[A5].CurrentRegion.Offset(1) For Each c In .Cells If LCase(c.Text) Like x And c.Row <> i Then Intersect(c.EntireRow, .Cells).Copy Range("G" & lig) i = c.Row lig = lig + 1 End If Next End With End Sub Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim r As Range, i As Variant Set r = Intersect(Target.EntireRow, Range("G4:M" & Rows.Count)) If r Is Nothing Then Exit Sub Cancel = True i = Application.Match(r(1), Feuil3.[A:A], 0) If IsNumeric(i) Then r.Copy Feuil3.Range("A" & i) 'transfert r.Delete xlUp 'suppression de la ligne End Sub
merci pour vos efforts et excellent travail merci encore mille merciBonjour kahlouch, le forum,
Je viens de modifier les macros Ajouter et Worksheet_Change (recherche) du post #2.
Pour tester cette dernière j'ai copié le tableau en feuille BA sur 20 000 lignes.
La recherche du caractère "@" et la restitution des 20 000 lignes se fait chez moi en 0,75 seconde.
Bonne journée.