XL 2010 j'ai besoin d'une autre macro de modification et sauvegarde

[kahlouch]

bonjour tout le monde
j'ai une table avec une macro de ajouter des données
mais j'ai besoin d'une autre macro de modification et sauvegarde
après une recherché des données enregistrées.

 

[job75]

Bonjour kahlouch,

Voyez le fichier joint et le code de la feuille "AA" :

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

A+

 

[kahlouch]

Bonjour kahlouch,

Voyez le fichier joint et le code de la feuille "AA" :

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

A+

merci beaucoup bon travail

 

[job75]

Bonjour 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.

 

[kahlouch]

Bonjour 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.

merci pour vos efforts et excellent travail merci encore mille merci