انشاء كود ترحيل فاتورة

[حسن البدوي0]

السلام عليكم ارجو منكم انشاء كود لترحيل اصناف الفاتورة الي المخزن

بحيث يوجد داخل ثلاث شيتات

الشيت الاول فاتورة بيع

الشيت الثاني فاتورة توريد

الشيت الثالث المخزن

اريد عند الضغط علي ترحيل يتم ترحيل المتر المربع لكل صنف في فاتورة البيع داخل المخزن بالثالب(يتم خصم من الكمية الموجود في المخزن)

اريد عند الضغط علي ترحيل يتم ترحيل المتر مريع لكل صنف في الفاتور التوريد داخل المخزن بالموجب(يتم اضهة علي الكمية الموجودة)

رصيد المخزن.xlsx

[سليم حاصبيا]

جرب هذا الملف

1-تسمية اوراق العمل دائماً باللغة الاجنبية وأرفض من الآن وصاعداً اي ملف اسماء صفحاته باللغة العربية لما يسبب هذا الشيء من اضطراب في الكود اضافة الى صعوبة نسخة ولصقة لظهور احرف غريبة فية (عند البعض طبعاً)
  مع احترامي الشديد للغتنا العربية (لغة القرآن الكريم) لكنها لا تصلح لوضع اكواد الـــ VBA (نسبة الأحطاء 70% حسب الدّراسات)

2- من المفروض اضافة القليل من البيانات في الأوراق العمل ولا تتكل على من يريد المساعدة للقيام بذلك

3- تم وضع بعض المعادلات التي تساعد في ادراج النتائج (دون ظهور الأصفار)

4- الصف رقم 6 في الاوراق Bay  و  Inport يجب ان يبقى فارغاً

الكود

Option Explicit
Sub From_Sheets_To_MaG()
Dim Inp As Worksheet, Bay As Worksheet
Dim Mag As Worksheet
Dim Sh As Worksheet
Dim L_Mag%, Max_ro%, col%, k%, ro%
Dim Fnd As Range, Wat As Range
Dim Old_val

Set Inp = Sheets("Inport")
Set Bay = Sheets("Bay")
Set Mag = Sheets("Magazine")

L_Mag = Mag.Cells(Rows.Count, 1).End(3).Row
Set Fnd = Mag.Range("A1:A" & L_Mag)
If Not (ActiveSheet.Name = "Inport" Or _
 ActiveSheet.Name = "Bay") Then Exit Sub
 Set Sh = ActiveSheet
 Select Case Sh.Name
  Case "Bay": col = 6
  Case "Inport": col = 5
  Case Else: Exit Sub
 End Select
 Max_ro = Application.Max(Sh.Range("B6:B68")) + 6
  For k = 7 To Max_ro
      Set Wat = Fnd.Find(Sh.Range("E" & k), lookat:=1)
        If Not Wat Is Nothing Then
         ro = Wat.Row
         Old_val = Val(Mag.Cells(ro, 3))
         Mag.Cells(ro, 7) = Old_val
         Mag.Cells(ro, col) = Val(Sh.Range("H" & k))
         Mag.Cells(ro, 3) = _
         Old_val + Val(Mag.Cells(ro, 5)) - Val(Mag.Cells(ro, 6))
        End If
   Next
End Sub

الملف مرفق

Hasan_B.xlsm

[حسن البدوي0]

شكرا استاذي علي هذا المجهود الرائع تم عمل اللازم بالظبط شكرا جدا