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

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


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

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

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

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

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

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

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
رابط هذا التعليق
شارك

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

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

مودتي لك

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

مودتي لك

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

  • أفضل إجابة

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

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
رابط هذا التعليق
شارك

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

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

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
رابط هذا التعليق
شارك

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

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

Important Information