Autres Modif sur macro appli J.Boisgontier...

Christian0258

XLDnaute Accro
Bonsoir à tout le forum,

Je souhaiterais une petite modif sur ce code (appli J.Boisgontier).
Actuellement, la macro place le N° de cde col E à hauteur du premier article validé, je souhaiterais que ce N° de cde soit placé devant chaque article... voir fichier joint
Merci pour votre aide.
Bien amicalement,
Christian

Sub majstock()
Set f = Sheets("saisie")
Set f2 = Sheets("BD")
Set d = CreateObject("scripting.dictionary")
Set Rng = f2.Range("A6:A" & f2.[A65000].End(xlUp).Row)
For Each c In Rng
If c.Value <> "" Then d(c.Value) = c.Offset(, 1)
Next c
If f.[A5] <> "" Then
Set Rng2 = f.Range("A5:A" & f.[A65000].End(xlUp).Row)
For Each c In Rng2
If c.Value <> "" Then d(c.Value) = d(c.Value) - c.Offset(, 1)
Next c
f2.[A6].Resize(d.Count) = Application.Transpose(d.keys)
f2.[B6].Resize(d.Count) = Application.Transpose(d.items)
[D1] = Value
'--- historique
lig = f2.[F65000].End(xlUp).Row + 1
f.[C1].Copy f2.Cells(lig, "E")
f.[D1].Copy f2.Cells(lig, "H")
Rng2.Resize(, 2).Copy f2.Cells(lig, "f")
f.[A5:B1000].ClearContents
f.[C1:D1].ClearContents
End If
End Sub
 

Pièces jointes

  • StockCommande3.xlsm
    33 KB · Affichages: 9

_Thierry

XLDnaute Barbatruc
Repose en paix
Bonjour @Christian0258 , le Forum

Sans toucher une virgule de code de Boisgontier, on peut ajouter simplement ce qu'on appelle une "verrue" :

VB:
Sub majstock()
  Set f = Sheets("saisie")
  Set f2 = Sheets("BD")
  Set d = CreateObject("scripting.dictionary")
  Set Rng = f2.Range("A6:A" & f2.[A65000].End(xlUp).Row)
  For Each c In Rng
    If c.Value <> "" Then d(c.Value) = c.Offset(, 1)
  Next c
  If f.[A5] <> "" Then
    Set Rng2 = f.Range("A5:A" & f.[A65000].End(xlUp).Row)
    For Each c In Rng2
      If c.Value <> "" Then d(c.Value) = d(c.Value) - c.Offset(, 1)
    Next c
    f2.[A6].Resize(d.Count) = Application.Transpose(d.keys)
    f2.[B6].Resize(d.Count) = Application.Transpose(d.items)
    [D1] = Value
    '--- historique
    lig = f2.[F65000].End(xlUp).Row + 1
    f.[C1].Copy f2.Cells(lig, "E")
    f.[D1].Copy f2.Cells(lig, "H")
    Rng2.Resize(, 2).Copy f2.Cells(lig, "f")
   'ajout Verrue ==================================================
    For X = f2.[E65000].End(xlUp).Row To f2.[F65000].End(xlUp).Row
        f.[C1].Copy f2.Cells(X, "E")
    Next X
    'fin ajout verrue =============================================
    f.[A5:B1000].ClearContents
    f.[C1:D1].ClearContents
  End If
End Sub

Bonne soirée
@+Thierry
 

Discussions similaires

Réponses
12
Affichages
225
Réponses
1
Affichages
122

Statistiques des forums

Discussions
311 733
Messages
2 082 019
Membres
101 872
dernier inscrit
Colin T