XL 2019 enregistrement sur dernière ligne vide

[julien35000]

Bonjour,

En onglet "par jour" j'ai mis un commentaire des anomalies non résolues.

Dans le fichier en onglet "a" je saisie pour chaque personnes "x" = journée, "am" après midi et "m" pour le matin.
Cela copie dans l'onglets "par jour", sauf que lorsque je saisie un "am" et après "x" cela efface le précedent.
Ensuite en cas de modif de l'onglet "a" la ligne s'efface en onglet "par jour" sans remonter les suivant afin d'éviter les ligne vide.

En espérant être assez explicite.

Cdt

 

[danielco]

Bonjour,

Donne un exemple.

Daniel

 

[job75]

Bonjour julien35000, danielco,

Voyez le fichier joint et le code de la feuille "PAR JOUR" :

Option Compare Text 'la casse est ignorée

Private Sub Worksheet_Activate()
Dim nom As Range, nlig&, P As Range, Q As Range, j%, memP, memQ, jour As Range, n%, i&, x$, k%
Set nom = Sheets(" a").[A7:A38] 'bah il y a un espace avant le a...
nlig = nom.Rows.Count
Set P = [F21:J35]
Set Q = [M21:M35]
Application.ScreenUpdating = False
For j = 0 To 30
    memP = P: memQ = Q 'mémorise les données des 2 tableaux
    P = "": Q = "" 'RAZ
    Set jour = nom.Offset(, 4 + j)
    n = 0
    For i = 1 To nlig
        x = jour(i)
        If x = "x" Or x = "m" Or x = "am" Then
            n = n + 1
            If n > 15 Then MsgBox "Le " & Format(jour(-1), "dd/mm/yyyy") & " plus de 15 cellules sont renseignées !", 48: Exit For
            If x = "x" Or x = "m" Then P(n, 2) = nom(i) & " " & nom(i, 2)
            If x = "x" Or x = "am" Then P(n, 4) = nom(i) & " " & nom(i, 2)
            x = P(n, 2) & Chr(1) & P(n, 4) 'texte concaténé à rechercher
            For k = 1 To 15
                If memP(k, 2) & Chr(1) & memP(k, 4) = x Then 'restitue les valeurs mémorisées
                    P(n, 1) = memP(k, 1)
                    P(n, 3) = memP(k, 3)
                    P(n, 5) = memP(k, 5)
                    Q(n) = memQ(k, 1)
                    Exit For
                End If
            Next k
        End If
    Next i
    Set P = P.Offset(20)
    Set Q = Q.Offset(20)
Next j
End Sub

La macro se déclenche quand on active la feuille.

La seule astuce est due au fait que les colonnes F H J M sont renseignées manuellement après coup.

Il faut donc mémoriser les tableaux pour pouvoir restituer les données de ces colonnes si nécessaire.

A+

 

[job75]

J'ai testé en entrant 15 "x" dans chacun des 31 jours de la 1ère feuille.

En activant la 2ème feuille la macro s'exécute chez moi en 3,1 secondes.

Bonne nuit.

 

[job75]

Utilisez ce fichier (2), la macro est beaucoup plus rapide grâce aux tableaux VBA a et b :

Option Compare Text 'la casse est ignorée

Private Sub Worksheet_Activate()
Dim nom As Range, nlig&, P As Range, Q As Range, j%, memP, memQ, a, b, jour As Range, n%, i&, x$, k%
Set nom = Sheets(" a").[A7:A38] 'bah il y a un espace avant le a...
nlig = nom.Rows.Count
Set P = [F21:J35]
Set Q = [M21:M35]
Application.ScreenUpdating = False
For j = 0 To 30
    memP = P: memQ = Q 'mémorise les données des 2 tableaux
    P = "": Q = "" 'RAZ
    a = P: b = Q 'matrices, plus rapides
    Set jour = nom.Offset(, 4 + j)
    n = 0
    For i = 1 To nlig
        x = jour(i)
        If x = "x" Or x = "m" Or x = "am" Then
            n = n + 1
            If n > 15 Then MsgBox "Le " & Format(jour(-1), "dd/mm/yyyy") & " plus de 15 cellules sont renseignées !", 48: Exit For
            If x = "x" Or x = "m" Then a(n, 2) = nom(i) & " " & nom(i, 2)
            If x = "x" Or x = "am" Then a(n, 4) = nom(i) & " " & nom(i, 2)
            x = a(n, 2) & Chr(1) & a(n, 4) 'texte concaténé à rechercher
            For k = 1 To 15
                If memP(k, 2) & Chr(1) & memP(k, 4) = x Then 'restitue les valeurs mémorisées
                    a(n, 1) = memP(k, 1)
                    a(n, 3) = memP(k, 3)
                    a(n, 5) = memP(k, 5)
                    b(n, 1) = memQ(k, 1)
                    Exit For
                End If
            Next k
        End If
    Next i
    '---restitution---
    If n Then
        P.Resize(n) = a
        Q.Resize(n) = b
    End If
    '---nouveaux tableaux---
    Set P = P.Offset(20)
    Set Q = Q.Offset(20)
Next j
End Sub

Dans les conditions du post #4 la macro s'exécute maintenant en 0,16 seconde.

Re bonne nuit.