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

[ابايوسف]

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

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

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

استعلام.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

[ابايوسف]

جزيت خيرا

فقط رجاء عند عدم كتابة شيء في خانة a2  تاتي كل البيانات الموجودة في الشيتات

مع جعل الارقام باللغة العربية 

 

 

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

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

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

[ابايوسف]

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

تسلم

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

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

جزيت خيرا

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

تم التعديل

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

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

Information_Advanced_Ar.xlsm

[ابايوسف]

السلام عليكم

من ادخلت البيانات

ممكن معالجة التاريخ  ليكون اليوم والشهر والسنة 23 / 5 / 2020 وطبعا بالعربي

تسلم

 

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

تقضل

Information_Advanced_Ar_date.xlsm

[ابايوسف]

تسلم 

جزيت خيرا

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

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

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

استدعاء البيانات من عدة شيتات مع التنسيق- واختيار راس الجدول.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  غير ضروري)

Information_Advanced_Ar_date_1.xlsm

[ابايوسف]

جزيت خيرا

تمام

وفيت وتفضلت - سلمك الله