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

[أبو أمين]

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

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

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

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

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

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

[أبو أمين]

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

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

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

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

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

Copie de dindin- recherche mot-3.xlsm

[بن علية حاجي]

السلام عليكم

تم عمل المطلوب (ما عدا تلوين كلمات البحث) بالتعديل على الكود المرفق في مشاركتك الأولى وإلغاء كود التغيير في حدث ورقة (شيت) Base... في العمود A من شيت Résultat وضعت كلمة البحث حسب عدد الصفوف التي وُجدت فيها... أرجو أن يفي الغرض المطلوب...

ملاحظة: عمل الملف يكون بطيئا أكثر كلما زادت كلمات البحث...

لم أستطع تلبية كل ما تطلبه... وأعتذر لذلك..

بن علية حاجي

Dindin__Recherche_mots_4.xlsm

[أبو أمين]

السلام عليكم

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

 

[أبو أمين]

السلام عليكم

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

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

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

إِذْ 

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

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

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

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

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

[محمد الجزيري]

اخواني القائمين علي المنتدي ارجو الافاده واضافة المعادلات 

 

Fr es t-Tuch net.zip