XL 2019 Archivage devis dans une feuille

[AIXELS]

Bonjour à tous les amis du Forum.
Je demande une fois de plus votre aide pour archiver des données
sur une feuille Historique, pour garder une trace.
Je vous ai joint le fichier avec des explications.
J'ai enregistré une macro, mais qui est lourde.
pourriez-vous l'améliorer pour une automatisation plus rapide.
Merci pour votre aide.
bien cordialement.

 

[sylvanu]

Bonjour Aixels,
Un essai en PJ avec :

Sub Archivage()
    Dim tablo, DL%, C%
    Application.ScreenUpdating = False
    tablo = Array("B7", "C7", "D7", "E7", "E8", "F7", "F8")
    With Sheets("HISTORIQUE_DEVIS")
        DL = .Range("A65500").End(xlUp).Row + 1
        For C = 1 To 1 + UBound(tablo)              'De N° à kilométrage
            .Cells(DL, C) = Range(tablo(C - 1))
        Next C
        .Cells(DL, UBound(tablo) + 2) = Cells(Range("F65500").End(xlUp).Row, "F")               'Montant
        .Cells(DL, UBound(tablo) + 3) = Cells(Application.Match("Remise", [D:D], 0), "E")       'Remise
    End With
End Sub

 

[patricktoulon]

re
Bonjour
un si petit transfert devrait etre instantané

le soucis c'est
1°que tu a des données sur une ligne même si les cellules sont fusionées[b7 à E7]
2°et que tu a des données sur deux lignes E8 . F7 . F8 . F19 . E21
donc pour le faire en One shot it is Not possible
cela dit en deux fois sans activation ou select quelconque on peut le faire
SI ON SE DÉBROUILLE BIEN

Sub ARCHIVER_DEVIS()
    Dim X
    With Feuil5.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .Resize(, 4).Value = Feuil1.[b7:e7].Value    'la partie ou il y a des fusion
        'la partie ou les données sont sr deux lignes
        X = Array( _
            Feuil1.[e8].Value, _
            Feuil1.[f7].Value, _
            Feuil1.[f8].Value, _
            Feuil1.[f19].Value, _
            Feuil1.[e21].Value)
        .Offset(, 4).Resize(, 5).Value = X
    End With
End Sub

Comme je disais c'est instantané

 

[sylvanu]

Re,
@patricktoulon
Si le devis "s'allonge" un peu, alors on ne peut pas de fier à F19 et E21 pour le TTC et la remise.
Il faut chercher où ils se trouvent sur la feuille.

 

[AIXELS]

Bonjour @sylvanu , @patricktoulon
Merci pour réponse respectives qui fonctionnent très bien.
@sylvanu pour répondre à ton interrogation concernant le total
et la remise, j'aurais du le préciser, j'utilise toujours le même devis
avec le même nombre de lignes, ils sont fixes.

Un problème auquel je suis confronté et que je n'avais pas prévu :
Si le N° de devis existe déjà, avoir la possibilité de l'écraser ou d'abandonner
l'archivage pour éviter d'avoir des doublons.

Merci pour votre aide.
Bien cordialement.

 

[sylvanu]

Re,
V2 en PJ.
Si le devis existe, sur demande, il est écrasé.

 

[AIXELS]

Re bonjour @sylvanu
Merci pour ta réactivité et ton aide.
Tout fonctionne très bien.
Bien cordialement.

 

[AIXELS]

Bonjour @sylvanu et tous les amis du Forum.
Je reviens vers toi pour te demander où je peux placer un message
de fin d'archivage quand on l'accepte ou quand on écrase un archivage
déjà existant dans la base.
Je l'ai placé à plusieurs endroits et il s'affiche systématiquement même
si on annule l'archivage.
Merci pour ton aide.
Bien cordialement.

 

[jcf6464]

Bonsoir à vous tous et le forum,
Chez moi en 365
cela fonctionne comme cela
Bonne continuation jcf

Sub Archivage()
    Dim tablo, DL%, C%
    Application.ScreenUpdating = False
    tablo = Array("B7", "C7", "D7", "E7", "E8", "F7", "F8", "F22", "E21")
    With Sheets("HISTORIQUE_DEVIS")
        If Application.CountIf(.[A:A], [B7]) <> 0 Then
            Rep = MsgBox("Ce devis est déjà archivé." & Chr(10) & Chr(10) & "Dois je l'écraser ?", vbYesNo, "N° de devis déjà existant")
            If Rep = vbNo Then Exit Sub
            Ligne = Application.Match([B7], .[A:A], 0)
        End If
        If Ligne <> "" Then DL = Ligne Else DL = .Range("A65500").End(xlUp).Row + 1
        For C = 1 To 1 + UBound(tablo)
            .Cells(DL, C) = Range(tablo(C - 1))
        Next C
    End With
  MsgBox Buttons:=vbInformation, Prompt:="    L'archivage du Devis " & vbNewLine & Chr(10) & "N°-->" & Sheets("DEVIS").[B7] & vbNewLine & Chr(10) & _
                  "c'est déroulé avec succès !", Title:="Info"


End Sub

 

[AIXELS]

Bonsoir @jcf6464
Merci pour ta réponse, qui fonctionne bien.
Merci pour ton aide.
Bien cordialement.