mahmoud nasr alhasany قام بنشر يناير 20 مشاركة قام بنشر يناير 20 (معدل) 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 رابط هذا التعليق شارك More sharing options...
mahmoud nasr alhasany قام بنشر يناير 20 الكاتب مشاركة قام بنشر يناير 20 رابط هذا التعليق شارك More sharing options...
mahmoud nasr alhasany قام بنشر يناير 23 الكاتب مشاركة قام بنشر يناير 23 الرجاء مساعدتى وان كان الموضوع الذى طرحتة سابقا لا يوجد به شئ مفهوما يتحدث من فضلكم وارجو من الاستاذ الرائع محمد هشام مساعدتى ان وقته يسمح بذلك رابط هذا التعليق شارك More sharing options...
mahmoud nasr alhasany قام بنشر يناير 26 الكاتب مشاركة قام بنشر يناير 26 السلام عليكم ورحمة الله وبركاتة رابط هذا التعليق شارك More sharing options...
mahmoud nasr alhasany قام بنشر يناير 27 الكاتب مشاركة قام بنشر يناير 27 وعليكم السلام ورحمة الله بركاته انا كويس رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان