الاعمدة في Listbox اكسل

[abed14092017]

مرحبا اخواني 

تحية طيبة ارجو ان تكون بخير و صحة  

ارفقت ملف اكسل 

بدخل الملف userform يحتوي على listbox و زر امر  , textbox

بحيث ابحث عن قيمة في textbox من مجموع من الصفحات , و تظهر النتائج في listbox 

لكن النتائج تضهر فقط 10 اعمدة 

وانا احاول ان اضيف عمود باسم الصفحة و عمود بموقع ( رقم الخلية) 

المطلوب : الكود يضهر 10 اعمدة فقط , ويرفض ان يضهر 12 عمود داخل listbox 

راجياً مساعدتكم و خبراتكم 

و تحياتي للجميع 

اخوكم عبدالله 

 

جديد.xlsm

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

1) هل البحث سيكون في عمود معين او في كل الاعمدة من A الى J 

2) نطاق البيانات لديك على الملف يبدأ من الخلية a2 والكود يتضمن (a12:j"& lastrow100") !!!! 

[abed14092017]

مرحبا اخ محمد هشام البحث في كل الاعمدة 

من الخلية a2 ولغاية اخر صف بالعمود j 

[محمد هشام.]

للتوضيح فقط
 لتجاوز حد 10 أعمدة لخاصية AddItem لعنصر التحكم، يتعين عليك استخدام إما خاصية القائمة المضافة من محتويات صفيف (يمكن أن تكون Range.Value) أو خاصية Rowsource المتصلة بنطاق ربما لو كان البحث في عمود محدد مسبقا ستكون الامور اسهل بكثير 
وفقًا لمتطلباتك.و لشكل الملف لديك يجب أن تفعل المصفوفة ثنائية الأبعاد ما تريد، ولاكن أثناء قيامك بالبحث في أوراق متعددة، ستحتاج إلى تحديد حجم المصفوفة بشكل صحيح عن طريق حساب إجمالي عدد التطابقات عبر جميع الأوراق أولاً قبل تعبئتها.

صراحة ليس لي  الكثير من الوقت لقضائه في هذا الأمر وتم اختباره فقط على بياناتك المرفقة  - وبالتالي فإن محاولاتي  لتحديث الكود الخاص بك قد تحتاج إلى بعض التعديل/ إعادة التفكير ولكن جرب ما إذا كان هذا سيفعل ما تريد

Private Sub CommandButton1_Click()
    Dim sh                  As Worksheet
    Dim Cpt        As String, SearchAddress    As String
    Dim Found               As Range, wsRangeArr()      As Range
    Dim CountAllMatches     As Long, CountMatch         As Long
    Dim i                   As Long, r                  As Long, c As Long
    Dim Search              As Variant, SearchRange     As Variant
    Dim SearchSheetsArr     As Variant, CopyArr()       As Variant
    
    Const ColCount  As Long = 12
    
    SearchAddress = "A:J"
    SearchSheetsArr = Array("عين غزال", "الجبيهة", "أربد", "الزرقاء")
    '----------------------------------------------------------------------------------------------------------
    Search = Me.TextBox1.Value
    If Len(Search) = 0 Then Exit Sub
    If IsDate(Search) Then Search = DateValue(Search): LookIn = xlFormulas Else LookIn = xlValues
    
    For Each sh In ThisWorkbook.Worksheets(SearchSheetsArr)
        CountMatch = Application.CountIf(sh.Range(SearchAddress), Search)
        If CountMatch > 0 Then
            i = i + 1: ReDim Preserve wsRangeArr(1 To i): Set wsRangeArr(i) = sh.Range(SearchAddress)
            'العدد الإجمالي لجميع التطابقات في النطاقات
            CountAllMatches = CountAllMatches + CountMatch
        End If
        CountMatch = 0
    Next sh
    On Error Resume Next
    If CountAllMatches > 0 Then
        ReDim CopyArr(1 To CountAllMatches, 1 To ColCount)
        
        'أوراق البحث / النطاقات مع التطابقات
        r = 0
        For Each SearchRange In wsRangeArr
            'نطاق البحث
            Set Found = SearchRange.Find(Search, LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
                Cpt = Found.Address
                Do
                    'ملء عناصر المصفوفة
                    r = r + 1
                    For c = 1 To UBound(CopyArr, xlColumns) - 2
                        CopyArr(r, c) = SearchRange.Cells(Found.Row, c).Text
                    Next c
                    CopyArr(r, c) = Found.Address
                    CopyArr(r, c + 1) = SearchRange.Parent.Name
                    Set Found = SearchRange.FindNext(Found)
                    
                Loop While Found.Address <> Cpt
            Set Found = Nothing
            
        Next SearchRange
        
    End If
    'ملء مربع القائمة أو الإبلاغ عن عدم وجود تطابقات
    With Me.ListBox1
        .ColumnCount = IIf(CountAllMatches > 0, ColCount, 1)
        .List = IIf(CountAllMatches > 0, CopyArr, Array("ما تحاول البحث عنه غير موجود في الاسواق"))
        .Font.Size = IIf(CountAllMatches > 0, 9, 24)
        .TextAlign = IIf(CountAllMatches > 0, fmTextAlignLeft, fmTextAlignCenter)
    End With
    
End Sub
Private Sub TextBox1_Change()
    If Len(Me.TextBox1) = 0 Then Me.ListBox1.Clear
End Sub
Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Me.TextBox1 = "": Me.ListBox1.Clear
End Sub

 

 

جديد v2.xlsm

تم تعديل مايو 13 بواسطه محمد هشام.

[abed14092017]

مشكور استاذ محمد هشام 

راح اجرب الكود 

بس شكل الكود معقدة شوي 

شاكر ذوق حضرتك 

[حسونة حسين]

وعليكم السلام ورحمه الله وبركاته

تفضل اخى جرب هذا التعديل

Option Explicit

Private Sub CommandButton1_Click()
    Dim Ws As Worksheet, CEl As Range, Sheets_name As Variant, Sh, Temp()
    Dim Str As String, i As Long, j As Long, Lr As Long
    Str = Me.TextBox1.Value

    Sheets_name = Array("عين غزال", "الجبيهة", "الجبيهة", "أربد", "الزرقاء")
    i = 0
    For Each Sh In Sheets_name
        Set Ws = ThisWorkbook.Sheets(Sh)
        Lr = Ws.Cells(Ws.Rows.Count, 9).End(xlUp).Row
        For Each CEl In Ws.Range("A2:J" & Lr)
            If InStr(CEl.Value, Str) > 0 Then
                i = i + 1
                ReDim Preserve Temp(1 To 12, 1 To i)
                For j = 1 To 10
                    Temp(j, i) = Ws.Cells(CEl.Row, j).Value
                Next j
                Temp(11, i) = Ws.Name
                Temp(12, i) = CEl.Address
            End If
        Next CEl
    Next Sh
    If i = 0 Then
        MsgBox "ما تحاول البحث عنه غير موجود في الاسواق ", vbInformation + vbSystemModal, "نظام البطاقات الائتمانية - Search "
        TextBox1.Text = ""
    Else
        Temp = Application.Transpose(Temp)
        With Me.ListBox1
            .ColumnCount = 12
            .ColumnWidths = "96,96,96,96,140,96,96,96,96,96,96,96"
            .Clear
            .List = Temp
        End With
    End If
End Sub

 

جديد.xlsm

[abed14092017]

حسونة حسين 

اشكرا جدا يا صديقي 

راح اجرب الكود 

[abed14092017]

استاذ حسونة حسين 

جربت الكود الكود رائع جداً و متتاز

اشكرك جزيل الشكر 

تم تعديل مايو 16 بواسطه abed14092017

[حسونة حسين]

الشكر لله اخى

الحمد لله الذي بنعمته تتم الصالحات 

[محمد هشام.]

في 15‏/5‏/2024 at 01:02, abed14092017 said:

راح اجرب الكود 

بس شكل الكود معقدة شوي

يسعدنا  حصولك على النتيجة المطلوبة لاكن  للفائدة فقط لا غير .

من الممكن تبسيط الكود لاكن هناك احتمالات واردة ربما  لم  تقم بتجربتها مثلا كالبحث عن قيمة فريدة  او رقم يتضمن قيمة عشرية 

الكود الخاص بي تم انشاءه لتطابق القيم ليس للبحث بالتشابه 

هدا لانك طلبت البحث بجميع الاعمدة  عن قيمة معينة او ربما لم استوعب طلبك جيدا 

.لقد فكرت مسبقا في اقتراح استادنا الغالي @حسونة حسين  لاكن للاسف يعطي اخطاء جرب ادخال قيمة غير مكررة   او  تاريخ غير مكرر والبحث عنها  او البحث عن رقم مثلا 3.530 ستلاحظ انه تم اظهار رسالة عدم تواجده . او تكراره في عدة اعمدة رغم وجوده مرة واحدة فقط على الملف 

بالتوفيق..........

 

 

جديد (1).xlsm

تم تعديل مايو 16 بواسطه محمد هشام.