البحث عن كلمة في عمود وإن وجدها أدرجها في خلية مجاورة

[ًعبد من عباد الله]

الأخوة الكرام

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

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

بالمرفق مثال وشكرا لكم وكل عام وأنتم بخير

New Microsoft Excel Worksheet.rar

تم تعديل مايو 10, 2016 بواسطه وائل أبو عبد الرحمن

[ياسر خليل أبو البراء]

أخي الكريم وائل شعبان

حسب طلبك وملفك المرفق إليك الكود التالي (رغم أنني أعلم أن الموضوع ما زال غير مكتمل أركان التوضيح الكامل وأعلم أن هناك توابع نظراً لقصور التوضيح) .. واوعى تزعل من كلامي ..

Sub Search_Using_Arrays()
    Dim Arr, Temp, I As Long
    
    Const strWord As String = "التجربة"
    Arr = Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row).Value
    ReDim Temp(1 To UBound(Arr, 1), 1 To 1)
    
    For I = 1 To UBound(Arr, 1)
        If InStr(Arr(I, 1), strWord) > 0 Then
           Temp(I, 1) = strWord
        End If
    Next I
    
    Range("A2").Resize(UBound(Temp, 1), UBound(Temp, 2)).Value = Temp
End Sub

تقبل تحياتي

 

Search For Specific Text Using Arrays YasserKhalil.rar

[ًعبد من عباد الله]

استاذى الغالى أبو البراء

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

أولا عذرا للتأخير في الرد النور كان مقطوع من العصر حتى هذه اللحظة 

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

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

جزاك الله خيرا وشكرا لك

على فكرة يا جماعة الخير القائمين على أمر المنتدى الكريم

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

[ياسر خليل أبو البراء]

أخي الفاضل وائل

تفضل التعديل التالي ليوافق طلبك إن شاء الله

Sub Search_Using_Arrays()
    Dim Arr, Temp, I As Long
    Dim strWord As String
    
    strWord = InputBox("أدخل كلمة البحث")
    If strWord = "" Then Exit Sub
    
    Arr = Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row).Value
    ReDim Temp(1 To UBound(Arr, 1), 1 To 1)
    
    For I = 1 To UBound(Arr, 1)
        If InStr(Arr(I, 1), strWord) > 0 Then
           Temp(I, 1) = strWord
        End If
    Next I
    
    Range("A2").Resize(UBound(Temp, 1), UBound(Temp, 2)).Value = Temp
End Sub

تقبل تحياتي

[ًعبد من عباد الله]

والله يا أستاذى الغالى أنا بجد عاجز عن الشكر شكر الله لك وبارك فيك وجزاك عنى كل خير ولكل الأخوة الكرام ولكل من له فضل علينا

[ياسر خليل أبو البراء]

الحمد لله الذي بنعمته تتم الصالحات والحمد لله أن تم المطلوب على خير

أما بخصوص عاجز عن الشكر فكلا ..فقد أديت ووفيت الشكر بقولك جزاك الله خيراً

ولك بمثل إن شاء الله

تقبل وافر تقديري واحترامي

[ًعبد من عباد الله]

نعم الحمد لله الذى هدانا لهذا وما كنا لنهتدى لولا أن هدانا الله

أخى واستاذى الحبيب / ياسر خليل أبو البراء

صباح طيب ومبارك بإذن الله

إذا سمحت لى بطلب أخر وأعتذر أنى لم أنتبه له قبل طرح الموضوع

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

[ياسر خليل أبو البراء]

أخي الكريم وائل جرب الملف المرفق

Sub Search_Using_Arrays()
    Dim Arr, Temp, I As Long, Counter As Long
    Dim strWord As String


    strWord = InputBox("أدخل كلمة البحث")
    If strWord = "" Then Exit Sub

    Application.ScreenUpdating = False
        With Sheet1
            Arr = .Range("B2:B" & .Cells(Rows.Count, 2).End(xlUp).Row).Value
            ReDim Temp(1 To UBound(Arr, 1), 1 To 1)
    
            For I = 1 To UBound(Arr, 1)
                If InStr(Arr(I, 1), strWord) > 0 Then
                    Temp(I, 1) = strWord
                    Counter = Counter + 1
                End If
            Next I
    
            .Range("A2").Resize(UBound(Temp, 1), UBound(Temp, 2)).Value = Temp
    
            If Counter >= 1 Then
                .Range("A1:B1").AutoFilter
                    With .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row)
                        .AutoFilter Field:=1, Criteria1:="<>"
                        .Offset(1).SpecialCells(xlCellTypeVisible).Copy Sheet2.Range("A" & Sheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1)
                        .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
                    End With
                .Range("A1:B1").AutoFilter
            End If
        End With
    Application.ScreenUpdating = True
End Sub

تقبل تحياتي

Search For Specific Text Using Arrays YasserKhalil V2.rar

[ًعبد من عباد الله]

الله أكبر ما شاء الله

تمام كده يا أخى الحبيب بارك الله فيك وجزاك خيرا

بالله عليك مكنش زعلان منى لطلبى لتعديل لم أنتبه له أنا عارف أن أنا تعبتك معايا

(نفسي افهم اللغورتيمات اللى بتكتبوها دى علشان متعبكش بس مش عارف مش عايزه تتعدل في دماغى)

نحبكم في الله زادكم الله علما وحلما

[ياسر خليل أبو البراء]

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

جزيت خيراً أخي العزيز وائل على دعائك الطيب المبارك ، ولك بمثل إن شاء الله

أحبك الله الذي أحببتنا فيه

**********

لو إنت فهمت اللوغاريتمات والكل فهم ، يبقا أبشر .. مفيش حد هيكون عنده مشاكل واحتمال المنتدى يقفل وكل واحد يروح بيته

إن شاء الله بالصبر والعزيمة والإرداة للتعلم تصل إلى مبتغاك .. وأنا لست إلا متعلم مجتهد

تقبل تحياتي

[ابو القبطان]

احسنت يا استاذ ياسر الفكرة ممتازه والتنفيذ رائع

دمت لنا

[ا بو سليمان]

ما شاء الله تبارك الله ابداع  حبيبنا ياسر

[ياسر خليل أبو البراء]

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

أخي العزيز أبو سليمان بارك الله فيك ومشكور على مرورك العطر وكلماتك الطيبة

تقبلوا وافر تقديري واحترامي