أبو أمين

السلام عليكم

إخواني عندي طلب لو سمحتم 

كيف يمكن تغيير الكود حتى يخرج لي نتائج صحيحية بمعنى يبحث عن الكلمة ذاتها و لا يدمج فروعها

عند البحث عن كلمة مثلا :

إِذْ 

يخرج فقط الجمل التي تحوي هذه الكلمة وليس الجمل التي تحوي بإذنه / بإذن الخ

هذا هو الكود وهو صراحة سريع غير أن النتائج غير مضبوطة 

Sub trans()
    raz
    Dim temoins As Boolean, mot$, p&, x&, oldmot$
    Application.ScreenUpdating = False
    With Sheets("base ")
        mot = ""
        For Each cel In .Range("A2:A51")
            mot = cel.Text
            If mot <> "" Then
                firstrow = Sheets("Résultat").Cells(Rows.Count, 2).End(xlUp).Offset(1).Row
                Sheets("Résultat").Cells(firstrow, 1) = mot

                With Sheets("Résultat").Cells(firstrow, 1).End(xlUp)
                    If mot <> oldmot Then .Value = .Value & vbCrLf & "(" & x & " fois)"
                End With
                x = 0
                oldmot = mot
                For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
                    p = InStr(1, .Cells(i, 2).Value, mot)

                    If p > 0 Then
                        .Cells(i, 2).Characters(p, Len(mot)).Font.ColorIndex = 3
                        x = x + 1
                        .Cells(i, 2).Resize(, 6).Copy Destination:=Sheets("Résultat").Cells(Rows.Count, 2).End(xlUp).Offset(1)
                        Debug.Print Cells(i, 2).Address(0, 0) & " position " & p
                        p = 0
                    End If
                Next
            End If
        Next
    End With
End Sub

مع الشكر الجزيل أنا احتاجه كثيرا إخواني

يمكنكم إستعمال نفس المرفقات

السلام عليكم

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

عندي قاعدة بيانات في شيت base تحوي أكثر من 6200 سطر

في A2 الى A51 توجد 50 كلمة كيف يمكنني ان ابحث عن الخمسين كلمة الواحدة تلو الاخرى ثم نسخ النتائج في شيت النتائج

نتيجة تلو نتيجة

ارفقت مثالا للملف 

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

Copie de dindin- recherche mot-3.xlsm

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

Sub raz()
    Sheets(2).Cells.Clear
End Sub
Sub trans()
    raz
    Dim temoins As Boolean, mot$, p&, x&
    With Sheets("base ")
        mot = .[A2].Text
        MsgBox mot
        firstrow = Sheets("Résultat").Cells(Rows.Count, 2).End(xlUp).Offset(2).Row
        For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
            p = InStr(1, .Cells(i, 2).Value, mot)
            If p > 0 Then
                x = x + 1
                .Cells(i, 2).EntireRow.Copy Destination:=Sheets("Résultat").Cells(Rows.Count, 2).End(xlUp).Offset(1).EntireRow
                Debug.Print Cells(i, 2).Address(0, 0) & " position " & p
                p = 0
            End If
        Next
        MsgBox x
    End With
    'ajout du compteur dans la cellule temoins en "A" dans "Résultat"
    With Sheets("Résultat").Cells(firstrow, 1).End(xlUp)
        .Value = .Value & vbCrLf & "(" & x & " fois)"
    End With
End Sub

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

كيف يمكنني أن أجعله يبحث عن ٥٠ كلمة واحدة تلو الأخرى ثم ينسخ النتائج واحدة تلو الأخرى أيضا بالمحافظة على ترتيب الكلمات.

الغاية هي ربح الوقت وعدم إستعمال نسخ لصق لكل كلمة على حدة

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

السلام عليكم

رغم انني حذفت اكثر الشيتات و 3 يو زرفورم الا ان الملف لا زال يفوق 1.7 mb

البرنامج يعمل بقيت بعض الأشياء التي أود إضافتها

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

عملية الفرز تتم بنجاح فائق بقيت إضافة عدد مرات التكرار لكل لقب .

السلام عليكم

أي كود استعمل ليتم الذهاب الى اخر سجل في الليست بوكس اوتوماتيكيا عند فتح الفورم

السلام عليكم 

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

مع الشكر الجزيل.....

هذه واجهة الدخول البرنامج بعد الإستفادة من أكواد الإخوة في هذاالمنتدى الرائع

بقيت بعض الصعوبات التي سأطرحها لآحقا

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

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

فقط قفت بتعديل بسيط هنا في السطر الثالث

Private Sub UserForm_Initialize()
   Label11.Caption = Label11.Caption & " " & DayNameArabic(Now())
    Label2.Caption = DayNameArabic(Now())
    Label3.Caption = Format(Now(), "dd")
    Label4.Caption = Format(Now(), "mm")
    Label5.Caption = Format(Now(), "yyyy")
    Label6.Caption = Format(DHijri(Now()), "dd")
    Label7.Caption = HijriMonth(Format(DHijri(Now), "mm"))
    Label8.Caption = Format(DHijri(Now()), "yyyy")

End Sub

لست املك في الأخير سوى الإعجاب بكل هذه القدرات وأسأل الله سبحانه أن يوفقنا حميعا إلى ما يحب و يرضى .

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

السلام عليكم جميعا و رحمة الله

هذه الصورة مرفقة  وهي ماخوذة من ملفك الذي ارفقته

السلام عليكم

أشكرك أخي ياسر خليل  , هذا بالظبط ما ابحث عنه . فقط المشكلة عندي ان الشهر العربي يظهر .... بحروف غريبة .

فما الحل من فضلكم....... علما ان عندي ويدوز 10.

حاولت تغيير الإسم فلم أفلح فقط نجحت في إضافة أبو أمين  . فالمعذرة  ......  

تم تغيير الإسم بحمد الله ... بعد بحث طويل  ......

المعذرة لكم مرة أخرى 

السلام عليكم

هذه اول مشاركة لي في هذا المنتدى , وانا معجب كثيرا بعباقرته 

سؤالي :  هل يمكن عرض تاريخ اليوم في ليبل على يوزر فورم بهذا الشكل

الأحد 1 محرم 1437

مع الشكر