طلب كود لاختصار النص

[nssj]

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

والاختصار المطلوب عبارة عن خطوتين:

أولا: حذف كل شيء في بداية النص إلى أول كلمة (عن)

وهذا يعني أنه إذا كان النص يبدأ أصلاً بـ (عن) فيتم تجاوز هذه الخطوة

ثانيا: وبعد الخطوة السابقة يحذف الكود كل ما بعد أول فقرة، بحيث لا يبقى في النص إلا الفقرة الأولى فقط.

يعني إذا كان النص هكذا:

  

يصبح هكذا:

 

وفي الملف المرفق جدولان: الأول (TAB) وهو المطلوب اختصاره، وقد قمت باختصاره يدويا في الجدول الثاني (TAB2) ليتضح المطلوب

Short text.accdb

[Moosak]

تفضل أخي العزيز هذه هي الدالة 🙂

=Mid([Text1];InStr(1;[Text1];"عن");InStr(1;[Text1];".")-InStr(1;[Text1];"عن")+1)

تضعها في مصدر مربع النص الذي سيظهر النتيجة ..

و Text1 هو مربع النص المصدر ..

أعتذر لعدم التطبيق في ملفك .. ليس لدي إنترنت في الجهاز.

اختصار الوقت.accdb

[nssj]

الأخ الكريم  Moosak  الحل الذي اقترحته قام بجزء كبير من المطلوب، لكن توجد ملاحظتان:

1 – إذا كان النص يبدأ أصلا بكلمة (عن) فالنتيجة صفحة خالية من أي نص، انظر عند التطبيق رقم (4)

وهذه الملاحظة يمكن تجاوزها مؤقتاً لأن الجدول المطلوب التطبيق عليه حاليا أنا متأكد أن جميع نصوصه لا تبدأ بعن، لكن إن أمكن حل هذه الإشكالية فهو أفضل عند التطبيق على جداول أخرى

2 – هذه الطريقة  تبقى على النص إلى أول نقطة ، كما جاء في الكود "." ، والمطلوب أول فقرة بمعنى سطر جديد، فقد يأتي في النص نقطة قبل نهاية الفقرة .. وأيضاً لا يشترط أن تكون نهاية الفقرة نقطة، فقد تكون فاصلة وقد لا يوجد في النص ولا نقطة كما في رقم (15) وعندها تكون النتيجة (#دالة!)

وجربت أن أستبدل "." بـ  (chr(13)) وما زبطت ..

Short text 2.accdb

[nssj]

في الملف المرفق محاولة لتوضيح المطلوب، حيث توجد ثلاث مربعات نص

في مربع النص الأول يظهر النص المطلوب وقد اختصرته يدويا

وفي الثاني النص الناتج عن الدالة التي تفضل بها الأخ Moosak .. وفي أول حديثين النتيجة موافقة للنص المطلوب، وفي الباقي تظهر الإشكاليات

وأهمها أن الدالة تقف عند أول نقطة "."   والمطلوب أن تقف عند نهاية الفقرة

وجربت أن أستبدل "."    بـ    [chr(13)  //  chr(10)  //  chr(13)+chr(10)] والنتيجة في المربع الثالث

فما هي الصيغة التي تؤدي المطلوب

Short text 3.accdb

[Moosak]

أعذرني أخي @nssj ..

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

[nssj]

منذ ساعه, rockjone33 said:

بدل كلمت "عن" و "." برمز لا يتكرر ..

أخي الكريم .. هذا غير وارد بالنظر لكبر حجم الجدول وتكرار كلمة عن .. لذلك انا بحاجة للقيام بالعملية برمجيا 🙂

[Moosak]

أهلا أخي @nssj  الكود السابق لم يعمل بسبب أن الرمز chr(10) ورد أكثر من مرة في النص .. وهو يحضر أول ورود له .. وأول ورود له يقع قبل كلمة "عن" لهذا السبب لم تعمل دالة mid..

لذلك قمت بعمل دالة تبحث عن ال chr(10) التي تقع بعد "عن" ..

هذه هي الدالة ضعها في محرر الأكواد :

Public Function MidText(strText As String) As String
Dim x As Integer
Dim t As String
Dim s As Integer
Dim L As Integer

s = InStr(1, strText, "عن")

For x = 1 To Len(strText)
    t = Mid(strText, x, 1)
    If t = ChrW(10) And x > s Then
        L = x
        Exit For
    End If
Next
    'Debug.Print s, L
    MidText = Mid(strText, s, L - s + 1)
End Function

ثم استدعها في مربع نص النتيجة هكذا :

=MidText([Text1])

حيث ان [Text1] هو اسم خلية المصدر

[nssj]

تمام أخي الكريم Moosak لم تعد هنا إشكالية بخصوص البحث عن أول فقرة بعد "عن"

وبقيت إشكالية ما إذا كان النص يبدأ أصلاً "بعن" فلا يظهر في النص المختصر شيء

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

أولاً إضافة مربع نص جديد، يكون مصدره النص القديم مع إضافة أي حرف في بدايته، وليكن ($) من خلال دالة 

=("$"+[Text1])

ثم تطبيق كود الاختصار عليه

هذا اللي عندي حسب معلوماتي المتواضعة .. فهل عندك حل آخر أكثر احترافية أخي الكريم 😁

 

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

تم تعديل أغسطس 10, 2022 بواسطه nssj

[Moosak]

2 ساعات مضت, nssj said:

تمام أخي الكريم Moosak لم تعد هنا إشكالية بخصوص البحث عن أول فقرة بعد "عن"

وبقيت إشكالية ما إذا كان النص يبدأ أصلاً "بعن" فلا يظهر في النص المختصر شيء

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

أولاً إضافة مربع نص جديد، يكون مصدره النص القديم مع إضافة أي حرف في بدايته، وليكن ($) من خلال دالة 

=("$"+[Text1])

ثم تطبيق كود الاختصار عليه

هذا اللي عندي حسب معلوماتي المتواضعة .. فهل عندك حل آخر أكثر احترافية أخي الكريم 😁

 

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

الموضوع صار بسيط الآن أخي @nssj 🙂

يمكن تطبيق فكرتك في الدالة الرئيسية ..

Public Function MidText(strText As String) As String
Dim Txt as String
Dim x As Integer
Dim t As String
Dim s As Integer
Dim L As Integer

Txt = "@@@" & strText
s = InStr(1, Txt, "عن")

For x = 1 To Len(Txt)
    t = Mid(Txt, x, 1)
    If t = ChrW(10) And x > s Then
        L = x
        Exit For
    End If
Next
    'Debug.Print s, L
    MidText = Mid(Txt, s, L - s + 1)
End Function

جرب وقلي .. 

لأني أكتب من الهاتف ..

[nssj]

هذه هي النتيجة أخي الكريم

[Moosak]

سأعالجه لك لاحقا بإذن الله

[Moosak]

تم ضبط الدالة ولله الحمد :

Public Function MidText(strText As String) As String
Dim x As Integer
Dim t As String
Dim s As Integer
Dim L As Integer

If IsNull(strText) Or strText = "" Then MidText = "": Exit Function

s = InStr(1, strText, "عن")

For x = 1 To Len(strText)
    t = Mid(strText, x, 1)
    If t = ChrW(10) And x > s Then
        L = x
        Exit For
    End If
Next
    If L = 0 Then L = Len(strText)
'    Debug.Print s, L
    MidText = Mid(strText, s, L - s + 1)
End Function

 

Short text.rar

[nssj]

أحسن الله إليك اخي الكريم  Moosak .. تم المطلوب بحمد الله

وهذه من فوائد عدم الابتعاد عن الجهاز  😅