تتبع توزيع مادة على الغرف

[محمد عدنان]

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

الماكرو الموجود بالملف  عمل الاستاذ @محمد هشام.   و له جزيل الشكر له  على مجهوده 

ارجو التعديل عليه بحيث يتم الاختيار من الخلية g2  ثم من الشيت data يجلب اسم المادة و رصيديها 

و جميع الغرف من السطر 4 التي يكون بها عدد  و يرحل الى شيت form3 بالاعمدة c11  e11  

يوجد في الملف شيت فورم مثال لاستدعاء المادة 17  , النتائج اسفلها 

بارك الله بكم و جزاكم الله كل خير 

DATA V3.xlsb

[Saleh Ahmed Rabie]

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

**لتعديل الماكرو الموجود بالملف:**

1. افتح ملف الإكسيل الذي يحتوي على الماكرو.
2. انتقل إلى علامة التبويب "المطور" (Developer).
3. انقر على زر "Visual Basic" (أو اضغط على Alt + F11).
4. في نافذة محرر Visual Basic، انقر على الماكرو "استدعاء بيانات المادة" في الجزء الأيسر.
5. قم بتعديل السطر التالي في كود الماكرو:

Range("G2").Value = "17"

إلى:

Range("G2").Value = InputBox("أدخل رقم المادة:")

6. قم بتعديل السطر التالي في كود الماكرو:

Sheets("data").Range("A2:B" & LastRow).Find(What:=Range("G2").Value, LookIn:=xlValues, LookAt:=xlPart).Offset(0, 1).Value

إلى:

Sheets("data").Range("A2:B" & LastRow).Find(What:=Range("G2").Value, LookIn:=xlValues, LookAt:=xlPart).Offset(0, 2).Value

7. احفظ التغييرات وأغلق نافذة محرر Visual Basic.

**لاستخدام الماكرو المعدل:**

1. حدد الخلية G2 في ورقة العمل التي تحتوي على الماكرو.
2. أدخل رقم المادة التي تريد استدعاء بياناتها.
3. اضغط على مفتاح "Enter".
4. سيتم جلب اسم المادة ورصيدها من ورقة العمل "data" وعرضها في الخلايا المقابلة في ورقة العمل الحالية.
5. سيتم أيضًا نقل جميع الغرف التي تحتوي على أرقام من السطر 4 في ورقة العمل الحالية إلى الأعمدة C11 وE11 في ورقة العمل "form3".

**ملاحظة:**

* يمكنك تعديل السطر 

LastRow = Sheets("data").Cells(Rows.Count, 1).End(xlUp).Row

` في كود الماكرو لتحديد نطاق البحث في ورقة العمل "data".
* إذا لم يتم العثور على المادة المحددة في ورقة العمل "data"، فسيتم عرض رسالة خطأ.

[محمد عدنان]

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

اخ @saleh rabea  لم افهم شيئ ارجو وضع الكود كامل  بارك الله فيك 

[محمد هشام.]

تفضل اخي تم استبدال الكود ليتناسب مع متطلباتك الحالية مع دمج الاكواد السابقة في نفس الملف 

Sub CopyData2()

Dim x&, OneRng As Range, rCrit As String
Dim srcWS As Worksheet, WS As Worksheet
Dim i As Long, lrow As Long

Set srcWS = Sheets("Data")
Set WS = Sheets("FORM3"): rCrit = WS.[G2].Value
'قم بتعديل كود التفقيط بما يناسبك
Const iCnt As String = "=IFERROR(@NombreToArabe(E9),"""")"
  
  If IsEmpty(WS.[G2].Value) Then: Exit Sub
  
   Set OneRng = srcWS.Columns(3).Find(What:=rCrit, LookIn:=xlValues, LookAt:=xlWhole)
   If OneRng Is Nothing Then
    MsgBox rCrit & " : " & "غير موجودة", vbInformation: Exit Sub
   Else
Application.ScreenUpdating = False
lrow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row

For i = 11 To lrow
    Union(WS.Range("C" & i), WS.Range("E" & i)).ClearContents
Next i
   x = OneRng.Row
   WS.[A9] = srcWS.Cells(x, 1) 'الرقم
    WS.[B9] = srcWS.Cells(x, 2) 'رقم صفحة
    WS.[C9] = srcWS.Cells(x, 3) 'نوع اللوازم و مواصفاتها
    WS.[D9] = srcWS.Cells(x, 4) 'رصيد السجل
    WS.[E9] = srcWS.Cells(x, 33) 'المجموع
    With WS.[F9]                 'العدد كتابة
    .Formula = [iCnt]: .Value = .Value
    End With
tmp = srcWS.Range("A4:AF" & srcWS.Cells(Rows.Count, 3).End(xlUp).Row).Value2
  Dim a(): ReDim a(1 To UBound(tmp) * UBound(tmp, 2), 1 To 5)
  n = 0
  For ligne = 1 To UBound(tmp, 1)
    For Col = 6 To UBound(tmp, 2)
     If tmp(ligne, 3) = rCrit And tmp(ligne, Col) <> "" Then
       n = n + 1
       a(n, 2) = tmp(1, Col)  'رؤوس الاعمدة
       a(n, 4) = tmp(ligne, Col) ' رصيد الغرف المتوفرة
     End If
    Next Col
  Next ligne
WS.Cells(k + 11, 2).Resize(n, 3 + 1) = a
IRow = WS.Cells(Rows.Count, "E").End(xlUp).Row + 1
WS.[F11] = Application.Sum(WS.Range("E11:E" & IRow)) ' مجموع عمود الرصيد
End If
Application.ScreenUpdating = True
End Sub

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

حاولت توضيح بعض النقط المهمة على الكود ليسهل عليك التعديل على حسب احتياجاتك مستقبلا. 

 

بالتوفيق .....

 

 

 

 

DATA V4.xlsb

تم تعديل مايو 23 بواسطه محمد هشام.

[محمد عدنان]

السلام عليكم 

اخ @محمد هشام.  بارك الله بك و جزاك الله  كل خير  

الكود يعمل بشكل جيد و ممتاز و تم تعديله بما هو مطلوب 

اما سبب مقدرتي على فهم الاكود  و هي جزء يسير تعلمته من هذا الموقع الرائع و الاستفادة منك و من الجميع الاساتذة 

بارك الله بكم و تفع الله بعلمكم الجميع