Remonter les valeurs d'un tableau d'1 ligne

Le 24/09/2018 à 10:37

Bonjour a tous,

Cela fait plusieurs jours que j'essai de faire des progra VBA pour améliorer les fichiers de l'entreprise mais je bloque sur plusieurs sujets...

L'un d'eux est la création d'un tableau avec enregistrement automatique des valeurs (en appuyant sur un bouton).

La copie marche super mais je voulais bloquer la saisie dans le tableau à un nombre x de valeur pour pas surcharger le graphe qui est lié.

Et là.... Voici le code qui pose problème c'est a partir de " If Not IsEmpty(Range("N12")) Then" je pense....

Private Sub CommandButton1_Click()

If Range("D9") = "" Or Range("D10") = "" Or Range("D11") = "" Or Range("J9") = "" Or Range("J10") = "" Or Range("J11") = "" Or Range("D13") = "" Then

MsgBox ("il manque des valeurs")

If Range("D9") = "" Then

Range("D9").Interior.ColorIndex = 6

Else

Range("D9").Interior.ColorIndex = 0

End If

If Range("D10") = "" Then

Range("D10").Interior.ColorIndex = 6

Else

Range("D10").Interior.ColorIndex = 0

End If

If Range("D11") = "" Then

Range("D11").Interior.ColorIndex = 6

Else

Range("D11").Interior.ColorIndex = 0

End If

If Range("J9") = "" Then

Range("J9").Interior.ColorIndex = 6

Else

Range("J9").Interior.ColorIndex = 0

End If

If Range("J10") = "" Then

Range("J10").Interior.ColorIndex = 6

Else

Range("J10").Interior.ColorIndex = 0

End If

If Range("J11") = "" Then

Range("J11").Interior.ColorIndex = 6

Else

Range("J11").Interior.ColorIndex = 0

End If

If Range("D13") = "" Then

Range("D13").Interior.ColorIndex = 6

Else

Range("D13").Interior.ColorIndex = 0

End If

Else

Range("D9").Interior.ColorIndex = 0

Range("D10").Interior.ColorIndex = 0

Range("D11").Interior.ColorIndex = 0

Range("J9").Interior.ColorIndex = 0

Range("J10").Interior.ColorIndex = 0

Range("J11").Interior.ColorIndex = 0

Range("D13").Interior.ColorIndex = 0

If Range("M7") = "" Then

Range("M7") = Now()

Else

ListObjects(1).ListRows.Add.Range(1, 1).Value = Now()

End If

If Not IsEmpty(Range("N12")) Then

Range("M8:T8") = Range("M7:T7")

Range("M9:T9") = Range("M8:T8")

Range("M10:T10") = Range("M9:T9")

Range("M11:T11") = Range("M10:T10")

Range("M12:T12") = Range("M11:T11")

Range("M13:T13") = Range("M12:T12")

Range("M14:T14") = Range("M13:T13")

Else

DLT = Range("M15").End(xlUp).Row

Range("N" & DLT) = Range("D12")

Range("O" & DLT) = Range("J12")

Range("P" & DLT) = "47.35"

Range("Q" & DLT) = "47.32"

Range("R" & DLT) = "46.9"

Range("S" & DLT) = "46.87"

Range("T" & DLT) = Range("D13")

'Remise à zéro

Range("D9:D11") = ""

Range("J9:J11") = ""

Range("D13") = ""

End If

End If

End Sub

j'espère avoir été assez clair sinon hésitez pas à poser des questions.

Ci-joint le fichier en question

Merci beaucoup d'avance!

10carte-de-controle-fourchette-test.xlsm (188.90 Ko)
Le 24/09/2018 à 11:35

Bonjour,

Essaie ceci :

Private Sub CommandButton1_Click()
Dim rng As Range, n As Long, DLT As Long
    With ActiveSheet
        Set rng = .Range("D9:D11,D13,J9:J11")
        n = Application.CountA(rng)
        If n <> 7 Then MsgBox ("il manque des valeurs"), 64, "Information"
        rng.Interior.ColorIndex = xlColorIndexNone
        rng.SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 6
        If .Range("M7") = "" Then
            .Range("M7") = Now()
        Else
            .ListObjects(1).ListRows.Add.Range(1, 1).Value = Now()
        End If
        If Not IsEmpty(Range("N12")) Then
            .Range("M8:T8") = .Range("M5:T5")
            .Range("M9:T9") = .Range("M8:T8")
            .Range("M10:T10") = .Range("M9:T9")
            .Range("M11:T11") = .Range("M10:T10")
            .Range("M12:T12") = .Range("M11:T11")
            .Range("M13:T13") = .Range("M12:T12")
            .Range("M14:T14") = .Range("M13:T13")
        Else
            DLT = .Range("M15").End(xlUp).Row
            .Range("N" & DLT) = .Range("D12")
            .Range("O" & DLT) = .Range("J12")
            .Range("P" & DLT) = "47.35"
            .Range("Q" & DLT) = "47.32"
            .Range("R" & DLT) = "46.9"
            .Range("S" & DLT) = "46.87"
            .Range("T" & DLT) = .Range("D13")
            'Remise ? z?ro
            rng.Value = ""
        End If
    End With
End Sub
Le 24/09/2018 à 11:58

Bonjour,

Merci pour votre réponse!

Y a juste une erreur d'exécution 1004 sur "rng.SpecialCells(xlCellTypeBlanks).Interior.ColorIndex = 6"

désolé du dérangement

Le 24/09/2018 à 12:11

C'est encore moi.

J'ai fait plusieurs test avec votre code et y a pas que cette anomalie.

Quand il manque une valeur, le message apparaît bien mais la suite du code se lance quand même et copie les valeurs. Du coup la moyenne se retrouve faussé et le graphe par la même occasion.

Et si toutes les valeurs sont présentes, là le code ne fonctionne pas.

Le 26/09/2018 à 15:32

Re,

Déjà bravo pour le programme vous avez fait en 5 lignes ce que je fais en 20

J'ai refait un test en changeant quelques ligne. On se rapproche de ce que je cherche et je vais essayer d'être un peu plus précis dans ma demande 

Private Sub CommandButton1_Click()
Dim rng As Range, n As Long, DLT As Long
    With ActiveSheet
        Set rng = .Range("D9:D11,D13,J9:J11")
        n = Application.CountA(rng)
        If n <> 7 Then MsgBox ("il manque des valeurs"), 64, "Information"
        rng.Interior.ColorIndex = 6
        If .Range("M7") = "" Then
            .Range("M7") = Now()
            DLT = .Range("M15").End(xlUp).Row
            .Range("N" & DLT) = .Range("D12")
            .Range("O" & DLT) = .Range("J12")
            .Range("P" & DLT) = "47.35"
            .Range("Q" & DLT) = "47.32"
            .Range("R" & DLT) = "46.9"
            .Range("S" & DLT) = "46.87"
            .Range("T" & DLT) = .Range("D13")
        Else
            .ListObjects(1).ListRows.Add.Range(1, 1).Value = Now()
            Range("M22:T22").Delete

        End If
        If Not IsEmpty(Range("N12")) Then
            Range("M7:T7").Delete Shift:=xlUp

            'Remise ? z?ro
            rng.Value = ""
        End If
    End With
End Sub

en gros :

  • je veux qu'à chaque appuie sur les bouton les valeurs s'enregistre dans le tableau a coté (colonne M à T) (ça c'est bon)
  • Au bout de 5 ou 6 valeurs (Ligne M13) le tableau arrête de "grandir" (j'y arrive pas, les valeurs se suppriment et le programme continue d'écrire en M14, M15, etc)
  • A partir de ce moment, à chaque appuie sur le bouton, les valeurs écrase la première ligne (M7) pour avoir le dernier enregistrement (en M13) avec tous les autres (M8 à M13 qui passeront de M7 à M12) pour garder un historique des mesures. (ça j'y arrive pas)
  • Dernier problème : le format de la feuille ne doit pas changer (en tête en pied de page) et à chaque enregistrement il y a création de ligne donc le pied de page disparait. (d'où la ligne delete M22:T22) mais c'est pas top.

Voilà vous savez tout...

Merci encore !!

Le 02/10/2018 à 08:15
Public i As Integer
Private Sub CommandButton1_Click()

'Bouton enregistrer les valeurs

If Range("D9") = "" Or Range("D10") = "" Or Range("D11") = "" Or Range("J9") = "" Or Range("J10") = "" Or Range("J11") = "" Or Range("D13") = "" Then
    MsgBox ("il manque des valeurs")

    If Range("D9") = "" Then
    Range("D9").Interior.ColorIndex = 6
    Else
    Range("D9").Interior.ColorIndex = 0
    End If

    If Range("D10") = "" Then
    Range("D10").Interior.ColorIndex = 6
    Else
    Range("D10").Interior.ColorIndex = 0
    End If

    If Range("D11") = "" Then
    Range("D11").Interior.ColorIndex = 6
    Else
    Range("D11").Interior.ColorIndex = 0
    End If

    If Range("J9") = "" Then
    Range("J9").Interior.ColorIndex = 6
    Else
    Range("J9").Interior.ColorIndex = 0
    End If

    If Range("J10") = "" Then
    Range("J10").Interior.ColorIndex = 6
    Else
    Range("J10").Interior.ColorIndex = 0
    End If

    If Range("J11") = "" Then
    Range("J11").Interior.ColorIndex = 6
    Else
    Range("J11").Interior.ColorIndex = 0
    End If

    If Range("D13") = "" Then
    Range("D13").Interior.ColorIndex = 6
    Else
    Range("D13").Interior.ColorIndex = 0
    End If

Else
    Range("D9").Interior.ColorIndex = 0
    Range("D10").Interior.ColorIndex = 0
    Range("D11").Interior.ColorIndex = 0
    Range("J9").Interior.ColorIndex = 0
    Range("J10").Interior.ColorIndex = 0
    Range("J11").Interior.ColorIndex = 0
    Range("D13").Interior.ColorIndex = 0

        If Not IsEmpty(Range("M13")) Then decallage
        'End If

        For i = 7 To 13
            If Range("M" & i) = "" Then ecriture_ligne
        Next i
End If
End Sub

Private Sub decallage()
'Remonter les valeurs du tableau d'une ligne
Range("M7:T12") = Range("M8:T13").Value
Range("M13:T13") = ""
End Sub

Sub ecriture_ligne()
Range("M" & i) = Now()
Range("N" & i) = Range("D12")
Range("O" & i) = Range("J12")
Range("P" & i) = "47,35"
Range("Q" & i) = "47,32"
Range("R" & i) = "46,9"
Range("S" & i) = "46,87"
Range("T" & i) = Range("D13")
i = 13
'Effacer les valeurs
Range("D9:D11") = ""
Range("J9:J11") = ""
Range("D13") = ""

End Sub

C'est bon j'ai trouvé la solution par moi même désolé du dérangement.

Je met mon code plus haut si ça intéresse quelqu'un

Merci

Rechercher des sujets similaires à "remonter valeurs tableau ligne"