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

فورم للبحث في أكثر من شيت

Saed983

بواسطه Saed983
في منتدى الاكسيل Excel

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

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

Saed983

Saed983

قام بنشر
قام بنشر

السلام عليكم ورحمة الله وبركاته
السادة الأفاضل 

في المرفق ملف اكسل يحوي عدة شيتات

أريد عند ادخال رقم حساب العميل في نموذج البحث أن يقوم بالبحث في كل الشيتات وجلب كل التحويلات الخاصة برقم الحساب هذا

وشكراً جزيلاً مقدماً

serach all sheet.xlsx

مهند محسن

مهند محسن

قام بنشر
قام بنشر

وعليكم السلام-اهلا بك فى المنتدى

كان عليك لزاما استخدام خاصية البحث فى المنتدى فقد تكرر طلبك فى العديد من المشاركات ومنها :

فورم التنقل بين الشيتات مع البحث والاضافة والتعديل والحذف

يوزرفورم بحث و تعديل وحذف مرن يصلح لأي قاعدة بيانات

  • Like 1
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

جرب هذا الكود 

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
  If Target.Address = "$A$2" And Target.Count = 1 Then
    Call find_Please(Me, Range("a2"))
  End If
Application.EnableEvents = True
End Sub
'++++++++++++++++++++++++++++

Sub find_Please(SH As Worksheet, Rg)
Dim Principal    As Worksheet
Dim Ro%, m%: m = 4
SH.Range("A4:E" & Rows.Count).Clear
Set Principal = Sheets("serch")

 For Each SH In Sheets
    If SH.Name <> Principal.Name Then
         On Error Resume Next
          Ro = SH.Range("c:c").Find(Rg, lookat:=1).Row
         On Error GoTo 0
         If Ro > 0 Then
           Principal.Cells(m, 1).Resize(, 5).Value = _
           SH.Cells(Ro, 1).Resize(, 5).Value
           m = m + 1
         End If
     End If
 Next
 If m = 4 Then _
 MsgBox "Current Account Not Found": Exit Sub

 With Principal.Range("A4:E" & m - 1)
  .Borders.LineStyle = 1
  .Font.Bold = True
  .Font.Size = 14
  .HorizontalAlignment = 2
  .VerticalAlignment = 2
 .Interior.ColorIndex = 24
 .InsertIndent 1
End With

End Sub

الملف مرفق

 

Search_Account.xlsm

  • Like 3
ابايوسف

ابايوسف

قام بنشر
قام بنشر (معدل)

السلام عليكم - تسلم - جزيت خيرا

غيرت بالكود ليناسب عملي وجعلت البحث على اساس خلية A  بدل C

ولكن توجد مشكلة بالقائمة المنسدلة - مرة تعمل ومرة لا تعمل

 

تم تعديل بواسطه ابايوسف
  • Like 1
Saed983

Saed983

قام بنشر
  • الكاتب
قام بنشر

أهلا بك أستاذي الكريم

وشكرا على الافادة ولكن هذه الفورمات تختلف ببعض الشيء عن ما طلبته وقد جربت احدها قبل رفع الطلب ولكن لم يحقق النتيجة المرجوة وأردت أن أحل هذه المشكلة عن طريق المعادلات فقط

مودتي لك

شكراً جزيلا على الرد وعلى الكود الرائع ولكن هناك مشكلة (يقوم بجلب التحويلات الخاصة برقم حساب العميل ويضيف اليها حساب اخر بشكل عشوائي)

مودتي لك

Saed983

Saed983

قام بنشر
  • الكاتب
قام بنشر

شكرا على المتابعة

بعض الحسابات وليس الجميعCapture.JPG.5ddcd8117e286d52a989c0e5abc5916e.JPG

مودتي لك

  • أفضل إجابة
سليم حاصبيا

سليم حاصبيا

قام بنشر
  • أفضل إجابة
قام بنشر

تم معالجة الامر بالتعديل على الكود كما يلي 

Option Explicit

Private Sub Worksheet_Activate()
Application.EnableEvents = False
fil_data_val
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
  If Target.Address = "$A$2" And Target.Count = 1 Then
    Call find_Please(Me, Range("a2"))
  End If
Application.EnableEvents = True
End Sub
'++++++++++++++++++++++++++++

Sub find_Please(SH As Worksheet, Rg)
Dim Principal    As Worksheet
Dim Ro%, m%: m = 4
Dim My_rg As Range
SH.Range("A4:E" & Rows.Count).Clear
Set Principal = Sheets("serch")

 For Each SH In Sheets
    If SH.Name <> Principal.Name Then
       Set My_rg = SH.Range("c:c").Find(Rg, lookat:=1)
        If My_rg Is Nothing Then GoTo Next_sh
          Ro = My_rg.Row
         If Ro > 0 Then
           Principal.Cells(m, 1).Resize(, 5).Value = _
           SH.Cells(Ro, 1).Resize(, 5).Value
           m = m + 1
         End If
     End If
Next_sh:
 Next
 If m = 4 Then _
 MsgBox "Current Account Not Found": Exit Sub

 With Principal.Range("A4:E" & m - 1)
  .Borders.LineStyle = 1
  .Font.Bold = True
  .Font.Size = 24
  .HorizontalAlignment = 2
  .VerticalAlignment = 2
 .Interior.ColorIndex = 24
 .InsertIndent 1
End With

End Sub
'++++++++++++++++++++++++++++
Sub fil_data_val()
Dim S As Worksheet, T As Worksheet
Dim dic As Object
Dim i%
Set S = Sheets("serch")

Set dic = CreateObject("Scripting.Dictionary")
For Each T In Sheets
    If T.Name = S.Name Then GoTo Next_T
     i = 2
     Do Until T.Range("c" & i) = vbNullString
      dic(T.Range("C" & i).Value) = vbNullString
      i = i + 1
      Loop
Next_T:
  Next T
 With S.Range("A2").Validation
 .Delete
 .Add 3, Formula1:=Application.Transpose(Join(dic.keys, ","))
 End With
 dic.RemoveAll: Set dic = Nothing
 Set T = Nothing: Set S = Nothing
 
End Sub

الملف من جديد

 

Search_Account _new.xlsm

  • Like 2
Saed983

Saed983

قام بنشر
  • الكاتب
قام بنشر

ألف شكر لحضرتك

الملف يعمل 100%

 

سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

في هذاه الحالة 

يلزم هذا الكود 

Option Explicit

Private Sub Worksheet_Activate()
Application.EnableEvents = False
fil_data_val
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
  If Target.Address = "$A$2" And Target.Count = 1 Then
    Call find_Please(Me, Range("a2"))
  End If
Application.EnableEvents = True
End Sub
'++++++++++++++++++++++++++++

Sub find_Please(SH As Worksheet, Rg)
    Dim Principal    As Worksheet
    Dim Ro%     'first found row
    Dim Ro_Atc% 'All Others found rows
    Dim m%: m = 4
    Dim My_rg As Range 'find range with Criteria in cell(A2)
SH.Range("A4:E" & Rows.Count).Clear
Set Principal = Sheets("serch")

 For Each SH In Sheets
    If SH.Name <> Principal.Name Then
       Set My_rg = SH.Range("C:C").Find(Rg, lookat:=1)
      If My_rg Is Nothing Then GoTo Next_sh
          Ro = My_rg.Row: Ro_Atc = Ro
         Do
             Principal.Cells(m, 1).Resize(, 5).Value = _
             SH.Cells(Ro_Atc, 1).Resize(, 5).Value
             m = m + 1
              Set My_rg = SH.Range("C:C").FindNext(My_rg)
            Ro_Atc = My_rg.Row
            If Ro_Atc = Ro Then Exit Do
         Loop
     End If
Next_sh:

 Next
 If m = 4 Then _
 MsgBox "Current Account Not Found": Exit Sub

 With Principal.Range("A4:E" & m - 1)
  .Borders.LineStyle = 1
  .Font.Bold = True
  .Font.Size = 24
  .HorizontalAlignment = 2
  .VerticalAlignment = 2
 .Interior.ColorIndex = 24
 .InsertIndent 1
End With

End Sub
'++++++++++++++++++++++++++++
Sub fil_data_val()
Dim S As Worksheet, T As Worksheet
Dim dic As Object
Dim i%
Set S = Sheets("serch")

Set dic = CreateObject("Scripting.Dictionary")
For Each T In Sheets
    If T.Name = S.Name Then GoTo Next_T
     i = 2
     Do Until T.Range("c" & i) = vbNullString
      dic(T.Range("C" & i).Value) = vbNullString
      i = i + 1
      Loop
Next_T:
  Next T
 With S.Range("A2").Validation
 .Delete
 .Add 3, Formula1:=Application.Transpose(Join(dic.keys, ","))
 End With
 dic.RemoveAll: Set dic = Nothing
 Set T = Nothing: Set S = Nothing
 
End Sub

الملف مرفق

 

Search_Account _repetitions.xlsm

  • Like 2
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

1-لا تجعل الخلية L1 فارغة ولا تحتوي على اسم اي شيت

2-اذا كان النطاق من L2 و نزولاً  فارغاً   الكود يأخذ كل الصفحات        وإلا الصفحات المحددة في هذا النطاق

3-عدم ترك خلايا فارغة بين اسماء الشيتات المطلوبة في العامود L

تفضل الكود المطلوب 

Option Explicit

Private Sub Worksheet_Activate()
Application.EnableEvents = False
fil_data_val
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
  If Target.Address = "$A$2" And Target.Count = 1 Then
    Call find_Please(Me, Range("a2"))
  End If
Application.EnableEvents = True
End Sub
'++++++++++++++++++++++++++++

Sub find_Please(SH As Worksheet, Rg)
    Dim Principal    As Worksheet
    Dim Ro%     'first found row
    Dim ACT_Ro% 'Actual row   All Others found rows
    Dim m%: m = 4
    Dim My_rg As Range 'find range with Criteria in cell(A2)
    Dim Mon_Array

SH.Range("A4:F" & Rows.Count).Clear
Set Principal = Sheets("serch")
 Mon_Array = Application.Transpose(Range("L2", Range("L1").End(4)))

 If UBound(Mon_Array) > Sheets.Count Then
        For Each SH In Sheets
          If SH.Name = Principal.Name Then GoTo Next_sh
           Set My_rg = SH.Range("C:C").Find(Rg, lookat:=1)
            If My_rg Is Nothing Then GoTo Next_sh
                Ro = My_rg.Row: ACT_Ro = Ro
               Do
                   Principal.Cells(m, 1).Resize(, 5).Value = _
                   SH.Cells(ACT_Ro, 1).Resize(, 5).Value
                   Principal.Cells(m, 6) = SH.Name
                   m = m + 1
                    Set My_rg = SH.Range("C:C").FindNext(My_rg)
                  ACT_Ro = My_rg.Row
                  If ACT_Ro = Ro Then Exit Do
               Loop
Next_sh:
      
       Next
 Else
  '================================================
 For Each SH In Sheets
        If SH.Name = Principal.Name Then GoTo Next_sh1
    If Application.CountIf(Principal.Range("L2:L50"), SH.Name) <> 0 Then
             Set My_rg = SH.Range("C:C").Find(Rg, lookat:=1)
          If My_rg Is Nothing Then GoTo Next_sh1
              Ro = My_rg.Row: ACT_Ro = Ro
             Do
                 Principal.Cells(m, 1).Resize(, 5).Value = _
                 SH.Cells(ACT_Ro, 1).Resize(, 5).Value
                 Principal.Cells(m, 6) = SH.Name
                 m = m + 1
                  Set My_rg = SH.Range("C:C").FindNext(My_rg)
                ACT_Ro = My_rg.Row
                If ACT_Ro = Ro Then Exit Do
             Loop
   End If
Next_sh1:

 Next
  
  '====================================
 End If
 
 
 If m = 4 Then _
 MsgBox "Current Account Not Found": Exit Sub

 With Principal.Range("A4:F" & m - 1)
  .Borders.LineStyle = 1
  .Font.Bold = True
  .Font.Size = 24
  .HorizontalAlignment = 2
  .VerticalAlignment = 2
 .Interior.ColorIndex = 24
 .InsertIndent 1
End With

End Sub
'++++++++++++++++++++++++++++
Sub fil_data_val()
Dim S As Worksheet, T As Worksheet
Dim dic As Object
Dim i%
Set S = Sheets("serch")

Set dic = CreateObject("Scripting.Dictionary")
For Each T In Sheets
    If T.Name = S.Name Then GoTo Next_T
     i = 2
     Do Until T.Range("c" & i) = vbNullString
      dic(T.Range("C" & i).Value) = vbNullString
      i = i + 1
      Loop
Next_T:
  Next T
 With S.Range("A2").Validation
 .Delete
 .Add 3, Formula1:=Application.Transpose(Join(dic.keys, ","))
 End With
 dic.RemoveAll: Set dic = Nothing
 Set T = Nothing: Set S = Nothing
 
End Sub

الملف مرفق

Saerch_by_Special_sheets.xlsm

  • Like 3
  • 3 weeks later...
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

انت استعملت الكود الذي يذكر لك المكرر في نفس الصفحة مرة واحدة

كات يجب استعمال الكود الثاني            اي الكود الموجود  في الرد على الأخ (ابا يوسف) التي تحمل عنوان :

في هذاه الحالة 

يلزم هذا الكود

 

  • Like 1
Saed983

Saed983

قام بنشر
  • الكاتب
قام بنشر

ألف شكر استاذ سليم
الكود يعمل بشكل سليم

زائر
هذا الموضوع مغلق.
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept