بكتب في خانه اسم الصنف عاوز ادخل مجموعه بيانات بحيث اما اكتب اسم الصنف يظهر هو والسعر

[mohamedsayed]

دوائي فواتير.xlsx

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

جرب هذا الكود

Option Explicit
Sub find_medicament()
Dim Rep As Worksheet
Dim sh As Worksheet
Dim Med_Name$
Dim r, m%: m = 6
Set Rep = Sheets("Repport")
Rep.Range("a6:H25").ClearContents
If Rep.Range("H5") = vbNullString Then Exit Sub
Med_Name = Rep.Range("H5")
For Each sh In Sheets
 If sh.Name <> Rep.Name Then
  If sh.Range("B:B").Find(Med_Name, lookat:=1) Is Nothing Then GoTo next_sh
   r = sh.Range("B:B").Find(Med_Name, lookat:=1).Row
   With Rep
      .Cells(m, 1) = sh.Name
      .Cells(m, 2) = sh.Range("A4")
      .Cells(m, 3) = sh.Range("D4")
      .Cells(m, 4) = sh.Range("F" & r)
      .Cells(m, 6) = sh.Range("G" & r)
  m = m + 1
  End With
End If
next_sh:
Next
End Sub
'+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=
Sub fil_dataval()
Dim Rep As Worksheet
Dim sh As Worksheet, my_rg As Range
Dim dic As Object
Dim i%: i = 6
Set Rep = Sheets("Repport")
Set dic = CreateObject("Scripting.dictionary")
For Each sh In Sheets
 i = 6
 If sh.Name <> Rep.Name Then
  Do Until sh.Range("b" & i) = vbNullString
   dic(sh.Range("b" & i).Value) = ""
    i = i + 1
  Loop
 End If
 Next
 With Rep.Range("H5").Validation
 .Delete
 .Add 3, Formula1:=Join(dic.keys, ",")
 End With

End Sub

الملف مرفق

Hospital_sal.xlsm

[mohamedsayed]

@

سليم حاصبي

شكرا ليك حضرتك جدا ا سليم  ممكن اتواص مع حضرتك للتوضيح اكثر