XL 2019 Archivage devis dans une feuille

AIXELS

XLDnaute Occasionnel
Supporter XLD
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.
 

Pièces jointes

  • HISTORIQUE DEVIS.xlsm
    50.7 KB · Affichages: 8

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Aixels,
Un essai en PJ avec :
VB:
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
 

Pièces jointes

  • HISTORIQUE DEVIS.xlsm
    49 KB · Affichages: 3

patricktoulon

XLDnaute Barbatruc
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 ;)
VB:
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é
 

AIXELS

XLDnaute Occasionnel
Supporter XLD
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.
 

AIXELS

XLDnaute Occasionnel
Supporter XLD
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.
 

Pièces jointes

  • HISTORIQUE DEVIS (2).xlsm
    50.2 KB · Affichages: 5
Dernière édition:

jcf6464

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

VB:
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
 

Discussions similaires

Membres actuellement en ligne

Statistiques des forums

Discussions
313 198
Messages
2 096 141
Membres
106 505
dernier inscrit
ngomez