اذهب الي المحتوي
أوفيسنا

استعلام عن رقم هوية في كافة الشيتات واظهار النتائج


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

الردود الموصى بها

السلام عليكم - عيدكم مبارك - وتقبل الله منكم الصيام والعمل المعروف

عندي مجموعة من الشيتات عند كتابة رقم الهوية تأتي كافة البيانات الموجودة في الشيتات

وعند عدم كتابة شيء تظهر كل البيانات الموجودة بالشيتات

استعلام.xlsx

رابط هذا التعليق
شارك

جرب هذا الكود

تسمية الورقة الأولى باسم  "Infos" لسهولة نسخ الكود ولصقه دون مشاكل اللغة

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
 If Target.Address = "$A$2" And Target.Count = 1 Then
 Find_Hawiyya
 End If
 Application.EnableEvents = True
 End Sub
'+++++++++++++++++++++++++++++
Sub Find_Hawiyya()
    Dim Inf As Worksheet, Act_sh As Worksheet
    Dim s_rg       As Range, find_rg As Range
    Dim Inf_rg     As Range
    Dim Targ_rg    As Range
    Dim Where_rg   As Range
    Dim m%, Ro%, x%, N%
    
    Set Inf = Sheets("Infos")
    Set s_rg = Inf.Range("A2")

N = Sheets.Count
m = 8
Set Inf_rg = Inf.Range("A7").CurrentRegion
Inf.Cells(2, 2) = vbNullString
If Inf_rg.Rows.Count > 1 Then _
   Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1).Clear
If s_rg = vbNullString Then Exit Sub
  For x = 1 To N
        If Sheets(x).Name = Inf.Name Then GoTo Next_x
        Set Act_sh = Sheets(x)
        Set find_rg = Sheets(x).Range("D:D")
        Set Targ_rg = find_rg.Find(s_rg, Lookat:=1)
        If Not Targ_rg Is Nothing Then
            Ro = Targ_rg.Row
            Inf.Cells(m, 2).Resize(, 18).Value = _
            Sheets(x).Cells(Ro, 2).Resize(, 18).Value
            Inf.Cells(m, 1) = m - 7
            m = m + 1
        End If
Next_x:
  Next x
If m = 8 Then MsgBox "No Data To Exract": Exit Sub
Set Inf_rg = Inf.Range("A7").CurrentRegion
If Inf_rg.Rows.Count = 1 Then Exit Sub
   With Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1)
        .Borders.LineStyle = 1: .InsertIndent 1
        .Font.Size = 16: .Font.Bold = True
        .Interior.ColorIndex = 19
    End With
Inf.Cells(2, 2) = Inf.Cells(8, "E")
End Sub

الملف مرغف

 

Infomation.xlsm

  • Like 3
رابط هذا التعليق
شارك

تم التعديل على الكود كما تريد

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
 If Target.Address = "$A$2" And Target.Count = 1 Then
      If Target = vbNullString Then
        Find_Hawiyya_ALL
      Else
        Find_Hawiyya
       End If
  End If
 Application.EnableEvents = True
 End Sub
'+++++++++++++++++++++++++++++
Sub Find_Hawiyya()
    Dim Inf As Worksheet, Act_sh As Worksheet
    Dim s_rg       As Range, find_rg As Range
    Dim Inf_rg     As Range
    Dim Targ_rg    As Range
    Dim Where_rg   As Range
    Dim m%, Ro%, x%, N%
    
    Set Inf = Sheets("Infos")
    Set s_rg = Inf.Range("A2")

N = Sheets.Count
m = 8
Set Inf_rg = Inf.Range("A7").CurrentRegion
Inf.Cells(2, 2) = vbNullString
If Inf_rg.Rows.Count > 1 Then _
   Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1).Clear
'If s_rg = vbNullString Then Exit Sub
  For x = 1 To N
        If Sheets(x).Name = Inf.Name Then GoTo Next_x
        Set Act_sh = Sheets(x)
        Set find_rg = Sheets(x).Range("D:D")
        Set Targ_rg = find_rg.Find(s_rg, Lookat:=1)
        If Not Targ_rg Is Nothing Then
            Ro = Targ_rg.Row
            Inf.Cells(m, 2).Resize(, 18).Value = _
            Sheets(x).Cells(Ro, 2).Resize(, 18).Value
            Inf.Cells(m, 1) = m - 7
            m = m + 1
        End If
Next_x:
  Next x
If m = 8 Then MsgBox "No Data To Exract": Exit Sub
Set Inf_rg = Inf.Range("A7").CurrentRegion
If Inf_rg.Rows.Count = 1 Then Exit Sub
   With Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1)
        .Borders.LineStyle = 1: .InsertIndent 1
        .Font.Size = 16: .Font.Bold = True
        .Interior.ColorIndex = 19
    End With
Inf.Cells(2, 2) = Inf.Cells(8, "E")
End Sub
'++++++++++++++++++++++++++++++++++++
Sub Find_Hawiyya_ALL()
    Dim Inf As Worksheet
    Dim s_rg       As Range
    Dim Inf_rg     As Range
    Dim Where_rg   As Range
    Dim m%, t%, x%
    Dim Dic As Object, ky
    Dim arr(11)
    
    Set Inf = Sheets("Infos")
    Set s_rg = Inf.Range("A2")
    Set Dic = CreateObject("Scripting.Dictionary")
   '============================
   Set Inf_rg = Inf.Range("A7").CurrentRegion
     
If Inf_rg.Rows.Count > 1 Then _
    Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1).Clear
      For t = 1 To 12: arr(t - 1) = t & "": Next
  m = 8
   '=======================
    If s_rg <> vbNullString Then Exit Sub
For x = 1 To Sheets.Count
    If IsError(Application.Match(Sheets(x).Name, arr, 0)) Then _
       GoTo Next_x
    Set Where_rg = Sheets(x).Range("a1").CurrentRegion
    
    If Where_rg.Rows.Count = 1 Then GoTo Next_x
    
    Set Where_rg = Where_rg.Offset(1).Resize(Where_rg.Rows.Count - 1)
        For t = 1 To Where_rg.Rows.Count
          Dic.Add (t - 1), Where_rg. _
          Rows(t).Cells(2).Resize(, 18).Value
        Next t
    
    For Each ky In Dic.keys
        Inf.Cells(m, 2).Resize(, 18) = Dic(ky)
        Inf.Cells(m, 1) = m - 7
        m = m + 1
    Next ky
Next_x:
    Dic.RemoveAll
Next x
Set Inf_rg = Inf.Range("A7").CurrentRegion
If Inf_rg.Rows.Count = 1 Then Exit Sub
   With Inf_rg.Offset(1).Resize(Inf_rg.Rows.Count - 1)
        .Borders.LineStyle = 1: .InsertIndent 1
        .Font.Size = 16: .Font.Bold = True
        .Interior.ColorIndex = 35
    End With
Inf.Cells(2, 2) = "ALL"

End Sub

الملف مرفق

 

Information_Advanced.xlsm

  • Like 2
رابط هذا التعليق
شارك

الله يرضى عليك

تسلم

طلب اخير - وهو ان تكون الارقام من الانكليزي 1234567890 الى العربي 

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

جزيت خيرا

  • Like 1
رابط هذا التعليق
شارك

تم التعديل

اذا كان الرقم وحيداً يكتب بالعربية

واذا كان مصحوباً مع اي شيء اخر   اكسل يتعبره نصاّ لذلك لا يدرجه بالعربية

Information_Advanced_Ar.xlsm

  • Like 2
رابط هذا التعليق
شارك

تسلم 

جزيت خيرا

الحمد لله اليكم - تم الأمر - هو المطلوب

عندي شغلة اخيرة - ما اعرف ارفعه ، والله استحي من كثرة طلباتي وسرعة استجابة الاستاذ سليم - جزاه الله خير - أم ارفعه مشاركة جديدة

ممكن اختيار بعض الاعمدة للظهور حسب الطلب

استدعاء البيانات من عدة شيتات مع التنسيق- واختيار راس الجدول.xlsm

رابط هذا التعليق
شارك

لا داعي لاي شيء 

فقط قم باخفاء الأعمدة التي لا تريدها

مستعملاً هذا الماكرو

Sub Hide_columns()
Dim k%
Sheets("Infos").Columns.Hidden = False
 Dim arr()
 arr = Array(3, 4, 5, 6, 7, 8, 9, 10)
 For k = LBound(arr) To UBound(arr)
 Sheets("Infos").Columns(arr(k)).Hidden = True
 Next
End Sub

في الصورة المرفقة حدد أرقام  الأعمدة التي تريد اخفا ئها من خلال Array  (تسلسل الأرقام داخل Array  غير ضروري)

CAP_1_1.png.ee50c3b1a2ba4d9e74b83fa5cc6f7c20.png

Information_Advanced_Ar_date_1.xlsm

  • Like 2
رابط هذا التعليق
شارك

زائر
هذا الموضوع مغلق.
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information