استدعاء مجتويات غرفة

[محمد عدنان]

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

ارجو المساعدة بماكرو يقوم من الصفحة form2 من الخلية g5  اختيار اسم الغرقة يقوم باستدعاء محتويات الغرفة من الشيت Data   جسب الفورم 

ملاحظة يقوم باستدعاء المحتويات التي الممتلئة فقط 

*  و ماكرو اخر يقوم الاستعلام باسم المادة و اماكن وجود ها بالغرف form3 

مرفق الملف 

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

 

DATA.rar

تم تعديل مايو 20 بواسطه محمد عدنان

[محمد هشام.]

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

Sub CopyData()      
Dim srcWS As Variant, _
 WS As Worksheet, _
     r As Range, _
OneRng As Range, rCrit As String
         
     Set srcWS = Sheets("Data")
     Set WS = Sheets("FORM2"): rCrit = WS.[G5]
     Const iCnt  As String = "=IFERROR(@NombreToArabe(E9),"""")"
     Set r = srcWS.Range("A4:AH4").Find(rCrit)
     Cpt = Array(2, 3, 4, 33)

With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False

If IsEmpty(WS.[G5].Value) Then: Exit Sub
rw = srcWS.Cells(srcWS.Rows.Count, "B").End(xlUp).Row
If Not r Is Nothing Then
    With srcWS
        Set OneRng = .Range(.Cells(5, r.Column), .Cells(rw, r.Column))
        If WorksheetFunction.CountA(OneRng) = 0 Then: _
           MsgBox "لا تتوفر نتائج على" & " : " & rCrit, vbInformation: Exit Sub
    End With
    
    WS.Range("A9:F" & WS.Rows.Count).ClearContents
    a = srcWS.Range("A5:AH" & srcWS.[A65000].End(xlUp).Row)

    For i = 1 To UBound(a)
    If a(i, r.Column) <> "" Then
      WS.Cells(F + 9, 2).Resize(, 4) _
               = Application.IfError(Application.Index(a, i, Cpt), "")
                F = F + 1
           End If
        Next
With WS
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
  With WS.Range("F9:F" & lastRow)
   .Formula = [iCnt]: .Value = .Value
   With WS.Range("A9:A" & lastRow)
    .Value = Evaluate("ROW(" & .Address & ")-8")
          End With
        End With
     End With
  End If
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

 

21 ساعات مضت, محمد عدنان said:

و ماكرو اخر يقوم الاستعلام باسم المادة و اماكن وجود ها بالغرف form3 

تمت اظافته للملف المرفق 

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

 

DATA V2.xlsb

[محمد عدنان]

السلام عليكم 

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

الفورم الاول لا يعطي ما هو موجود  في الغرفة مثال الغرفة 1  يعطي مادة 1 1 مادة 3 1    في خانة  او عمود  الرصيد  و هكذا

    لكن الفورم الثاني ليس كما هو مطلوب 

المطلوب في form3   ان اختار المادة من الخلية g5  بكود يحدد اسماء الغرف المتواجدة و عددها في كل غرفة  مرفق مثال كما في الصورة

تم تعديل مايو 21 بواسطه محمد عدنان

[محمد هشام.]

19 ساعات مضت, محمد عدنان said:

الفورم الاول لا يعطي ما هو موجود  في الغرفة مثال الغرفة 1  يعطي مادة 1 1 مادة 3 1    في خانة  او عمود  الرصيد  و هكذا

    لكن الفورم الثاني ليس كما هو مطلوب 

المطلوب في form3   ان اختار المادة من الخلية g5  بكود يحدد اسماء الغرف المتواجدة و عددها في كل غرفة  مرفق مثال كما في الصورة

اخي طلبك غير واضح بالنسبة لي ما هي علاقة الغرفة 1 بالمادة 13 مثلا !!!!!!!!!!!!  حتى لو قمت بتجربة الدهاب الى عمود الغرفة 1 وقمت بفلترتها على الخلايا الغير فارغة لن تجد غرفة 13  في عمود (نوع اللوازم و مواصفاتها ) 

ربما يجب عليك  اعادة صيغة طرح طلبك مع مزيدا من التوضيح او ارفاق عينة للنتائج المتوقعة 

 

المرجوا جعل كل طلب في موضوع مستقل 

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

[محمد هشام.]

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

بعد معاينة بعض التعاليق التي قمت انت  باظافتها على الكود لاحظت انك ترغب بجلب بيانات عمود الغرفة المحددة الى عمود الرصيد ورقة FORM2  كان بوسعنا فعل دالك

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

 

Sub CopyData()
'“Update the code

    Dim OneRng As Range, r As Range, rw As Long, lastrow As Long
    Dim srcWS As Worksheet: Set srcWS = Sheets("Data")
    Dim WS  As Worksheet: Set WS = Worksheets("FORM2"): rCrit = WS.[G5]
    '“Adjust the formula to suit you
    Const iCnt  As String = "=IFERROR(@NombreToArabe(E9),"""")"
    '“Room search scope
    Set r = srcWS.Range("A4:AH4").Find(rCrit)
 
If IsEmpty(WS.[G5].Value) Then: Exit Sub
  rw = srcWS.Columns("A:AH").Find(What:="*", _
          SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
 
 If Not r Is Nothing Then
   With srcWS
    '“Set range (starting cell 5 of target column)
        Set OneRng = .Range(.Cells(5, r.Column), .Cells(rw, r.Column))
        If WorksheetFunction.CountA(OneRng) = 0 Then: _
         MsgBox "لا تتوفر نتائج على" & " : " & rCrit, vbInformation, _
                                  "Information :": Exit Sub
    End With
    
    Application.ScreenUpdating = False
    WS.Range("A9:F" & WS.Rows.Count).ClearContents
    
    With srcWS
        If .AutoFilterMode Then .AutoFilterMode = False
    End With
    '“Column headers
    With srcWS.Range("A4:AH4")
        .AutoFilter r.Column, "<>"
        
 '(1)“If the columns are not adjacent
'        rngA = Split("A,B,C,D", ",")
'        rngB = Split("A,B,C,D", ",")
'    For i = LBound(rngA) To UBound(rngA)

With srcWS
 '(2) '.Range(rngA(i) & "5:" & rngA(i) & rw).Copy
 '     WS.Range(rngB(i) & "9").PasteSpecial Paste:=xlPasteValues

'“From column ("A") to ("D")
.Range("A5:D" & rw).SpecialCells(xlCellTypeVisible).Copy
  WS.Range("A9").PasteSpecial Paste:=xlPasteValues
    
   'Copy the target column data
    .Range(.Cells(5, r.Column), _
    .Cells(rw, r.Column)).SpecialCells(xlCellTypeVisible).Copy
      WS.Range("E9").PasteSpecial Paste:=xlPasteValues

        End With
      '(3) Next i
 .AutoFilter
 End With
With WS
'“Add the formula to the column of numbers in writing ("F")
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
    With WS.Range("F9:F" & lastrow)
     .Formula = [iCnt]: .Value = .Value
          End With
       End With
    End If
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

يمكنك تعديل الكود بما يناسبك 

 

 

DATA V2-1.xlsb

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

[محمد عدنان]

السلام عليكم 

اخ @محمد هشام. بعتذر منك لاني ما اقدر ت اوصل الك ما اريد بطريقة مبسطة  

الكود الكود يعمل بشكل ممتار 

اما بالنسبة FORM3  يكون الاستعلام بالعكس من الكود الاول 

اي اختار اسم الماد ة .... و النتيجة موقعها في الغرف 

بارك الله فيك و اشكرك 

[محمد هشام.]

تمام اخي بما انك توصلت للنتيجة المتوقعة بخصوص الطلب الاول يفضل غلق الموضوع 

اما بخصوص طلبك الثاني ساقوم بنشره بادن الله في مكانه الصحيح بعد اظافة ورقة FROM3

 

 

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