Historique de validation

Le 14/06/2022 à 13:57

coucou tous le monde j'espere que vous aller bien

je veux cree une macro que copie les cellules suivantes (B1, B3, A6, B6, E20, F20) de la feuille calcule sur la derniere lignes de la feuilles Historique

des idees ?

22prod.xlsm (33.09 Ko)
Le 14/06/2022 à 15:53

un petit essaye

Sub histo()
Dim lRow As Long
Set hs = Sheets("Historique")
Set cs = Sheets("calcul")
lRow = hs.Cells(Rows.Count, 1).End(xlUp).Row
'date
cs.Range("B1").Copy
hs.Range("A" & lRow + 1).PasteSpecial xlPasteValues
'nom
cs.Range("B3").Copy
hs.Range("B" & lRow + 1).PasteSpecial xlPasteValues
'non prod
cs.Range("E20").Copy
hs.Range("E" & lRow + 1).PasteSpecial xlPasteValues
'temps
cs.Range("F20").Copy
hs.Range("F" & lRow + 1).PasteSpecial xlPasteValues
'client
cs.Range("A6:A19").Copy
hs.Range("C" & lRow + 1).PasteSpecial xlPasteValues
'reference
cs.Range("B6:B19").Copy
hs.Range("D" & lRow + 1).PasteSpecial xlPasteValues

End Sub

le probleme danc 'reference' et 'client' il copies toutes les cellules , je veux qu'il copie juste les cellules non vides

Le 15/06/2022 à 05:30

Bonjour,

Ceci (non testé)

Sub Histo()
    Dim lRow_Hs As Long, lRow_Cs As Long, i As Long
    Dim Hs As Worksheet, Cs As Worksheet
    Application.ScreenUpdating = False
    Set Hs = Sheets("Historique")
    Set Cs = Sheets("calcul")
    lRow_Cs = Cs.Cells(Rows.Count, 1).End(xlUp).Row
    lRow_Hs = Hs.Cells(Rows.Count, 1).End(xlUp).Row
    If lRow_Cs > 5 Then
        For i = 6 To lRow_Cs
            Hs.Range("A" & lRow_Hs + 1).Value = Cs.Range("B1").Value 'date
            Hs.Range("B" & lRow_Hs + 1).Value = Cs.Range("B3").Value 'nom
            Hs.Range("E" & lRow_Hs + 1).Value = Cs.Range("E20").Value 'non prod
            Hs.Range("F" & lRow_Hs + 1).Value = Cs.Range("F20").Value 'temps
            Hs.Range("C" & lRow_Hs + 1) = Cs.Cells(i, "A") 'client
            Hs.Range("D" & lRow_Hs + 1) = Cs.Cells(i, "B")  'reference
        Next i
        lRow_Hs = lRow_Hs + 1
    End If
End Sub

Cdlt

Le 15/06/2022 à 09:36

merci bcp Arturo83, ui je viens de modifier mon code et il marche bien , just une toute petites modification si possible, alors apres lajoute je veux que le nom se duplique

screenshot 2022 06 15 at 08 30 18

par exemple le nom ahmed se duplique sur B3, aussi samira B5 et B6, Alex sur B8 et B9 ...

Le 15/06/2022 à 12:10

Ceci:

Sub Histo()
    Dim lRow_Hs As Long, lRow_Cs As Long, i As Long
    Dim Hs As Worksheet, Cs As Worksheet
    Application.ScreenUpdating = False
    Set Hs = Sheets("Historique")
    Set Cs = Sheets("calcul")
    lRow_Cs = Cs.Cells(Rows.Count, 1).End(xlUp).Row
    lRow_Hs = Hs.Cells(Rows.Count, 1).End(xlUp).Row
    If lRow_Cs > 5 Then
        For i = 6 To lRow_Cs
            Hs.Range("A" & lRow_Hs + 1).Value = Cs.Range("B1").Value 'date
            Hs.Range("B" & lRow_Hs + 1).Value = Cs.Range("B3").Value 'nom
            Hs.Range("E" & lRow_Hs + 1).Value = Cs.Range("E20").Value 'non prod
            Hs.Range("F" & lRow_Hs + 1).Value = Cs.Range("F20").Value 'temps
            Hs.Range("C" & lRow_Hs + 1) = Cs.Cells(i, "A") 'client
            Hs.Range("D" & lRow_Hs + 1) = Cs.Cells(i, "B")  'reference
        Next i
        lRow_Hs = lRow_Hs + 1
    End If

    'Ajout des noms manquants
    For i = 3 To lRow_Hs
        If Hs.Cells(i, "B") = "" Then Hs.Cells(i, "B") = Hs.Cells(i - 1, "B")
    Next i
End Sub

Cdlt

Le 15/06/2022 à 17:32

merci beaucoup ca marche tres bien, est ce qu'il ya une moyenne de copie tous le range de A6 jusqua F& last row, de la fauille de calcule

jai essaye de modifier le code mais ca marche pas

Sub Histo1()
    Dim lRow_Hs As Long, lRow_Cs As Long, i As Long
    Dim Hs As Worksheet, Cs As Worksheet
    Application.ScreenUpdating = False
    Set Hs = Sheets("Historique")
    Set Cs = Sheets("calcul")
    lRow_Cs = Cs.Cells(Rows.Count, 1).End(xlUp).Row
    lRow_Hs = Hs.Cells(Rows.Count, 1).End(xlUp).Row
    If lRow_Cs > 5 Then
        For i = 6 To lRow_Cs
            Hs.Range("A" & lRow_Hs + 1).Value = Cs.Range("B1").Value 'date
            Hs.Range("B" & lRow_Hs + 1).Value = Cs.Range("B3").Value 'nom
            Hs.Range("I" & lRow_Hs + 1).Value = Cs.Range("E20").Value 'T non prod
            Hs.Range("J" & lRow_Hs + 1).Value = Cs.Range("F20").Value 'T temps
            Hs.Range("C" & lRow_Hs + 1) = Cs.Range("A6:F" & lRow_Cs + 1) 'table
        Next i
        lRow_Hs = lRow_Hs + 1
    End If

    'Ajout des noms manquants
    For i = 3 To lRow_Hs
        If Hs.Cells(i, "B") = "" Then Hs.Cells(i, "B") = Hs.Cells(i - 1, "B")
    Next i
End Sub
Le 15/06/2022 à 17:45

Désolé, je ne comprends pas, redéposez le fichier avec les résultats attendus,

Le 15/06/2022 à 18:05
5prod.xlsm (25.48 Ko)
Le 15/06/2022 à 18:19

Le fichier est vide, ça ne m'aide pas du tout, je voudrais qu'il soit rempli avec quelques exemples de résultats attendus.

Le 15/06/2022 à 19:17

Voila et merci

9prod.xlsm (26.51 Ko)
Le 16/06/2022 à 06:41

Bonjour,

Essayez ceci:

Sub Histo()
    Dim lRow_Hs As Long, lRow_Cs As Long, i As Long
    Dim Hs As Worksheet, Cs As Worksheet
    Application.ScreenUpdating = False
    Set Hs = Sheets("Historique")
    Set Cs = Sheets("calcul")
    lRow_Cs = Cs.Cells(5, 1).End(xlUp).CurrentRegion.Row + 4
    lRow_Hs = Hs.Range("histo_tbl").Rows.Count
    If lRow_Hs > 1 Then lRow_Hs = Hs.ListObjects("histo_tbl").DataBodyRange.Rows.Count + 1
    If lRow_Cs > 5 Then
        For i = 6 To lRow_Cs
            Hs.Range("A" & lRow_Hs + 1).Value = Cs.Range("B1").Value 'date
            Hs.Range("B" & lRow_Hs + 1).Value = Cs.Range("B3").Value 'nom
        Next i
        lRow_Hs = lRow_Hs + 1
    End If
    Range(Cs.Cells(6, "A"), Cs.Cells(lRow_Cs, "F")).Copy Hs.Cells(lRow_Hs, "C")

    'Ajout des noms manquants
    For i = 3 To lRow_Hs + 1
        If Hs.Cells(i, "B") = "" Then Hs.Cells(i, "B") = Hs.Cells(i - 1, "B")
    Next i
End Sub

Attention, avant de commencer, supprimer les dernières lignes vides du tableau structuré de la feuille "Historique".

Cdlt

Le 16/06/2022 à 08:01

bonjour,

excel a ajouté un outil fantastique : un tableau, donc il faut utiliser ses characteristiques et cela facilite enorme !

Sub Histo()
     Dim LO    As ListObject, i, c, cNouveau

     Set LO = Sheets("Historique").ListObjects("histo_tbl")     'votre tableau
     With Sheets("calcul")     'votre données
          For Each c In .Range("A6:A18").Cells     'toute cette plage
               If Len(c.Value) > 0 Then     'cellule non vide
                    Set cNouveau = LO.ListRows.Add.Range.Range("A1").Resize(, 8)     'nouvelle plage (ligne) ajoutée au tableau
                    cNouveau.Resize(, 2).Value = Array(.Range("B1").Value, .Range("B3").Value)     '2 premières cellules
                    cNouveau.Cells(1, 3).Resize(, 6).Value = c.Resize(, 6).Value     '6 autres cellules
               End If
          Next
     End With

     With LO.DataBodyRange     'ce tableau
          For i = 2 To LO.ListRows.Count
               If .Cells(i, "B") = "" Then .Cells(i, "B") = .Cells(i - 1, "B") '     'Ajout des noms manquants
          Next i
     End With
End Sub
Le 16/06/2022 à 09:39

merci a vous , maintenant il marche tres tres bien et ui cest tres interessant d'utiliser listobjects

Rechercher des sujets similaires à "historique validation"