اريد كود تصفية كلمة من عبارة في الخلية

[aburajai]

السلام عليكم

كيف الحال ايها الاعواء

صديق قديم يطلب المساعدة

في تصفية كلمة من فقرة في خلية  مع تصدير النتائج فقط الى شيت جديد باسم الكلمة

انظر الملف المرفق

مع الشكر الجزيل لكم وبارك الله فيكم

اوفسينا.xls

[محي الدين ابو البشر]

عليكم السلام

ربما

Sub test()
Dim a
Dim i&, c&
a = Sheets("sheet1").Cells(5, 1).CurrentRegion.Columns(1)
With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "جميلة"
        For i = 1 To UBound(a)
        If .test(a(i, 1)) Then
        Sheets("جميلة").Cells(c + 1, 1) = a(i, 1)
        c = c + 1
        End If
       Next
    End With
End Sub

 

[أ / محمد صالح]

يمكنك تجربة هذه المحاولة بالمعادلات

بدلا من تصدير النتائج في شيت جديد يمكنك كتابة مصطلح البحث والحصول على النتائج في شيت النتائج

أهم شيء معادلة المسلسل في شيت البيانات data

لأن معادلة البحث vlookup تعتمد عليها

بالتوفيق

فلترة نتائج البحث في شيت جديد.xls

[محي الدين ابو البشر]

حل آخر

Sub test2()
    Dim a
    Dim i&, c&
    a = Sheets("sheet1").Cells(5, 1).Resize(Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row - 4)
    For i = 1 To UBound(a)
        If a(i, 1) <> "" Then
            If IsNumeric(Application.Match("جميلة", Split(a(i, 1)), 0)) Then
                Sheets("جميلة").Cells(c + 1, 1) = a(i, 1)
                c = c + 1
            End If: End If
    Next
End Sub

 

[aburajai]

اخي وضعته كماكرو في الملف لكن لم يعمل ؟
هل تذكرني بالطريقة الصحيحة لوضعه

اشكرك

الاستاذ محمد صالح

لو سمحت ممكن تضيف اللون لكلمة البحث في شيت البحث

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

لان احيانا الفقرة تكون كبيرة 

فاريد يبدا من 10 كلمات قبلها و 10 كلمات بعدها

بارك الله فيك

[محي الدين ابو البشر]

تفضل

اوفسينا.xlsm

[aburajai]

لا اعرف السبب في ذلك

فقد فتحته فلم اجد انه تم الترحيل الى شيت جميل

انظر الصورة ؟

 

[محي الدين ابو البشر]

لا أدري ما المشكلة عندك

على كل اتبع ما هو هو مكتوب في المرفق

اوفسينا.xlsm

[aburajai]

بارك الله فيكم

استاذ ابو اليسر

لو سمحت تعملع امتداد   xls
مش عارف افتحه على امتداد xlsm

شكرا لك 

[محي الدين ابو البشر]

xlsاوفسينا.xls

[aburajai]

استاذ

محي الدين ابو البشر

• شكرا لك
  الان نمام

لو تكرمت فيما لو كانت الفقرة طويلة فاريد ان تعمل جلب كلمة "جميلة" وقبلها 10 كلمات وبعدها 10 كلمات

شكرا لكم

 

تم تعديل سبتمبر 21, 2023 بواسطه aburajai

[محي الدين ابو البشر]

السلام عليكم

عذراً أخي الكريم على التأخير في الرد

استبدل test2 بـ الكود

Sub test2()
    Dim a, y
    Dim i&, c&, x&
    Application.ScreenUpdating = False
    Sheets("جميلة").Columns(1).ClearContents
    a = Sheets("sheet1").Cells(5, 1).Resize(Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row - 4)
    For i = 1 To UBound(a)
        If a(i, 1) <> "" Then
            y = Split(a(i, 1))
            If IsNumeric(Application.Match("جميلة", Split(a(i, 1)), 0)) Then
                x = Application.Match("جميلة", Split(a(i, 1)), 0)
                If UBound(y) > 21 Then
                    y = Application.Transpose(Application.Index(y, Evaluate("row(" & x - 10 & ":" & x + 10 & ")")))
                    Sheets("جميلة").Cells(c + 1, 1) = Join(y)
                Else
                    Sheets("جميلة").Cells(c + 1, 1) = a(i, 1)
                End If
                c = c + 1
            End If: End If
    Next
    Sheets("جميلة").Activate
    Application.ScreenUpdating = True
End Sub

 

[aburajai]

في 24‏/9‏/2023 at 12:53, محي الدين ابو البشر said:

Sub test2()
    Dim a, y
    Dim i&, c&, x&
    Application.ScreenUpdating = False
    Sheets("جميلة").Columns(1).ClearContents
    a = Sheets("sheet1").Cells(5, 1).Resize(Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row - 4)
    For i = 1 To UBound(a)
        If a(i, 1) <> "" Then
            y = Split(a(i, 1))
            If IsNumeric(Application.Match("جميلة", Split(a(i, 1)), 0)) Then
                x = Application.Match("جميلة", Split(a(i, 1)), 0)
                If UBound(y) > 21 Then
                    y = Application.Transpose(Application.Index(y, Evaluate("row(" & x - 10 & ":" & x + 10 & ")")))
                    Sheets("جميلة").Cells(c + 1, 1) = Join(y)
                Else
                    Sheets("جميلة").Cells(c + 1, 1) = a(i, 1)
                End If
                c = c + 1
            End If: End If
    Next
    Sheets("جميلة").Activate
    Application.ScreenUpdating = True
End Sub

 

السلام عليكم

وضعته ماكرو جديد 

لكن عمل ديبج على هذا السطر كما في الصورة

لا تنسى استاذ ان الملف امتداد XLS

تم تعديل سبتمبر 25, 2023 بواسطه aburajai

[محي الدين ابو البشر]

xlsاوفسينا.xls