مشكله عند الترحيل

[mahmoud nasr alhasany]

Private Sub CommandButton1_Click()
Dim n
   If CB_Pièce = "Code article" Then
      MsgBox "Veuillez choisir un Code article.", 64, "Article requis": CB_Pièce.SetFocus: Exit Sub
   End If
   If Val(TextBox81) = 0 Then MsgBox "Stock provenance vide => retrait impossible !": Exit Sub
   If ComboBox2 = "" Then MsgBox "Veuillez choisir un Magasin de destination.": Exit Sub
   Dim T$, Qté&, chn$, b As Byte: T = "Contrôle Quantité"
  
   chn = TextBox82: If chn = "" Then MsgBox "Veuillez saisir une Quantité.", 64, T: Quantitetr.SetFocus: Exit Sub
   chn = Replace$(chn, ",", "."): If InStr(chn, ".") > 0 Then b = 1   'ni « , » ni « . » car Qté : nombre entier !
   Qté = Val(chn): If Qté = 0 Then b = 1   'si chn est du texte ou 0, alors Qté = 0 => refusé !
   If b = 1 Then
      MsgBox "Veuillez entrer une quantité valide !", 64, T
      Quantitetr = "": Quantitetr.SetFocus: Exit Sub
   End If
   If Qté > Val(stocktr.Caption) Then
      MsgBox "Quantité supérieure au stock actuel !", 64, T
      Quantitetr = "": Quantitetr.SetFocus: Exit Sub
   End If
   If Val(seuil.Caption) > Val(stocktr.Caption) Then
      MsgBox "Impossible d'effectuer ce transfert !", 64, T
      Quantitetr = "": Quantitetr.SetFocus: Exit Sub
   End If
   'si y'a pas eu d'écriture sur "Inventaire", on quitte cette sub SANS
   Call MajInventaire: If lgD = 0 Then Exit Sub   'appeler LigneTransfert
   Call LigneTransfert: If lgT = 0 Then UndoOpInv
   'ci-dessus : si y'a pas eu d'écriture sur "Transfert", faut ANNULER
   'l'opération qui a été faite sur "Inventaire", car une opération de
   'transfert n'est PAS valable si on n'a pas pu l'écrire sur une des
   'deux feuilles "Inventaire" ou "Transfert".
   Unload Me
End Sub
Private Sub MajInventaire()
Dim QS&, n&, v
   With Worksheets("Inventaire")
      flgAdd = 0
      n = UBound(TblInv): lgS = 0: lgD = 0
      GetLig ComboBox1, n, lgS: If lgS = 0 Then Exit Sub
      GetLig ComboBox2, n, lgD: If lgD > 0 Then flgAdd = 1
      If lgD = 0 Then
         flgAdd = 0: lgD = n + 3
         If lgD = 65000 Then
            MsgBox "Le tableau en feuille Inventaire est plein !", 48
            lgD = 0: Exit Sub   'on fait rien, et on sort de la sub !
         End If
      End If
      Application.ScreenUpdating = 0: .Unprotect: QT = Val(Quantitetr)

      With .Cells(lgS, 11)  ' était (lgS, 3)
         QS = .Value + QT: .Value = QS: stocktr = QS
      End With
      Application.EnableEvents = False
      .Activate     ' active la feuille
      
      If flgAdd = 0 Then
      ' insère une ligne
      .Rows("4:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
      .Unprotect
      .Rows("5:5").Copy                         ' copie la ligne en dessous
      .Rows("4:4").PasteSpecial xlPasteFormats  ' colle le format

      .Range("D5").Copy        ' copie la cellule
      .Range("D4").Select      ' sélectionne la cellule
      ActiveSheet.Paste        ' colle (formule incluse)

      Application.EnableEvents = True

      lgD = 4
      End If
For v = 0 To ListBox1.ListCount - 1
      With .Cells(lgD, 3)
         If flgAdd = 0 Then
            .Offset(, -2) = ListBox1.List(v, 3)           'Code article
            .Offset(, -1) = ListBox1.List(v, 4)             'Catégorie
            .Offset(, 2) = ListBox1.List(v, 5)              'Seuil d'alerte
            .Offset(, 3) = ListBox1.List(v, 6)              'Descriptif
            .Offset(, 4) = ListBox1.List(v, 7)               'Référence
            .Offset(, 5) = ListBox1.List(v, 8)              'Unité de mesure
            .Offset(, 6) = "Transfert"         'Observations
            .Offset(, 9) = ComboBox2           'Magasin
            QD = Val(.Value) + QT: .Value = QD   'Stock actuel
         Else
            .Offset(, 7) = .Offset(, 7) + Quantitetr '
         End If
         lgT = lgT + 1

      
      End With
      .Protect: Application.ScreenUpdating = -1
      Next
   End With
   
End Sub
Private Sub LigneTransfert()
Dim v
   'remplir une ligne sur le tableau de la feuille "Transfert",
   'mais s'il n'y a plus de ligne libre, on ne fait rien !
   With Worksheets("Transfert")
   'Lastrow = Range("a" & Rows.Count).End(xlUp).Row + 1

      lgT = .Cells(Rows.Count, 1).End(3).Row + 1
      For v = 0 To ListBox1.ListCount - 1

      If lgT = 650000 Then
         MsgBox "Le tableau en feuille Transfert est plein !", 48
         lgT = 0: Exit Sub   'on fait rien, et on sort de la sub !
      End If
      Dim Stock1&, Stock2&
      Application.ScreenUpdating = 0: .Unprotect
      ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
      Stock2 = Val(stocktr): Stock1 = Stock2 + QT
      ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
      With .Cells(lgT, 1)
         .Value = CB_Pièce          'Code article
         .Offset(, 1) = ListBox1.List(v, 2)      'Catégorie
         .Offset(, 2) = ListBox1.List(v, 3)      'Désignation
         .Offset(, 3) = ListBox1.List(v, 4)       'Référence
         ' .Offset(, 4) = ListBox1.List(v, 4)      'Stock actuel
         .Offset(, 5) = ListBox1.List(v, 6)       'Unité
         .Offset(, 6) = Date        'Date
         .Offset(, 7) = ComboBox1   'Provenance
         .Offset(, 8) = ComboBox2   'Destination
         .Offset(, 9) = QT '= ListBox1.List(v, 13)       'Quantité transférée
         '.Offset(, 10) = Stock2     'STOCK PR
         ' .Offset(, 11) = QD         'STOCK DES
         .Offset(, 12) = TextBox1
         .Offset(, 13) = Format(Now, "mm/dd/yyyy hh:mm am/pm")
         lgT = lgT + 1
      End With
      .Protect: Application.ScreenUpdating = -1
      Next
   End With
End Sub

 

 

يوجد يوزرفورم Transfer1

نظرا لكثرة الاصناف اضفت listbox1  الى الفورم

وعند ترحيل البيانات الى الليست بوكس يعمل بنجاح ولاكن عند ترحيلها الى ورقة العمل لايقوم بالحفظ يوجد خطاء ولا اعرف السبب

تحويلات بين المخازن2.xlsm

تم تعديل يناير 20 بواسطه mahmoud nasr alhasany

[mahmoud nasr alhasany]

[mahmoud nasr alhasany]

الرجاء مساعدتى  

وان كان الموضوع الذى طرحتة سابقا لا يوجد به شئ مفهوما يتحدث من فضلكم 

وارجو من الاستاذ الرائع محمد هشام مساعدتى ان وقته يسمح بذلك

[mahmoud nasr alhasany]

السلام عليكم ورحمة الله وبركاتة

[mahmoud nasr alhasany]

وعليكم السلام ورحمة الله بركاته

انا كويس