مطلوب كود لنقل رقم بين رموز معينة لعمود آخر ثم حذف السطر كاملا

[nssj]

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

في الملف المرفق جدول (Book) وفيه حقل (Nass) يبدأ بأرقام بين &1&&

والمطلوب نقل الرقم فقط لحقل  (page)

وللتوضيح فقط عملت المطلوب في أول خمسة صفوف

ثم كود آخر لحذف هذه الأسطر التي تبدأ بـ (&) لأنه لم تعد لها حاجة

والأفضل أن يكون كل كودا منفصلا عن الآخر، فلا يلزم من استخدام أحدهما أن أستخدم الآخر

Book.rar

[ابو البشر]

42 دقائق مضت, nssj said:

في الملف المرفق جدول (Book) وفيه حقل (Nass) يبدأ بأرقام بين &1&&

والمطلوب نقل الرقم فقط لحقل  (page)

تفضل .....

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

Sub ExtractSingleNumber()
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim strPattern As String
    Dim strInput As String
    Dim regExp As Object
    Dim matches As Object
    
    ' النمط لاستخراج الرقم بين & و &&
    strPattern = "&(\d+)&&"
    
    ' تهيئة قاعدة البيانات
    Set db = CurrentDb
    Set rs = db.OpenRecordset("SELECT nass, page FROM book")
    
    ' تهيئة كائن التعبير النمطي
    Set regExp = CreateObject("VBScript.RegExp")
    regExp.Pattern = strPattern
    regExp.Global = False
    
    ' المرور عبر السجلات
    Do While Not rs.EOF
        strInput = rs!nass
        
        If regExp.Test(strInput) Then
            Set matches = regExp.Execute(strInput)
            rs.Edit
            rs!Page = matches(0).SubMatches(0) ' الرقم المستخرج
            rs.Update
        End If
        
        rs.MoveNext
    Loop
    
    ' تنظيف الموارد
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set regExp = Nothing
    
    MsgBox "تم نسخ الأرقام إلى الحقل page بنجاح!"
End Sub

والكود التالي لحذف السطر الذي به النمط
تفضل ......
 

Sub RemoveAllPatterns()
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim strPattern As String
    Dim strInput As String
    Dim regExp As Object
    
    ' النمط لإزالة كل ما يشبه &رقم&&
    strPattern = "&\d+&&"
    
    ' تهيئة قاعدة البيانات
    Set db = CurrentDb
    Set rs = db.OpenRecordset("SELECT nass FROM book")
    
    ' تهيئة كائن التعبير النمطي
    Set regExp = CreateObject("VBScript.RegExp")
    regExp.Pattern = strPattern
    regExp.Global = True ' لضمان إزالة جميع التطابقات داخل النص
    
    ' المرور عبر السجلات
    Do While Not rs.EOF
        strInput = rs!nass
        
        If regExp.Test(strInput) Then
            rs.Edit
            ' إزالة جميع التطابقات للنمط من النص
            rs!nass = regExp.Replace(strInput, "")
            rs.Update
        End If

        rs.MoveNext
    Loop
    
    ' تنظيف الموارد
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set regExp = Nothing
    
    MsgBox "تم حذف جميع الأنماط &رقم&& بنجاح!"
End Sub

 

[nssj]

أحسن الله إليك أخي الكريم

الكودان يؤديان المهمة المطلوبة

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

[ابو البشر]

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

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

 

جرب هذا ........................

Sub CleanAndRemovePatterns()
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim strPattern As String
    Dim strInput As String
    Dim updatedText As String
    Dim regExp As Object

    On Error GoTo ErrorHandler

    Set db = CurrentDb
    Set rs = db.OpenRecordset("SELECT ID, nass FROM book", dbOpenDynaset)

    strPattern = "&\d+&&"
    Set regExp = CreateObject("VBScript.RegExp")
    regExp.Pattern = strPattern
    regExp.Global = True
    
    Do While Not rs.EOF
        If Not IsNull(rs!nass) Then
            strInput = rs!nass
            updatedText = strInput

            If regExp.Test(updatedText) Then
                updatedText = regExp.Replace(updatedText, "")
            End If

            If Left(updatedText, 2) = vbCrLf Then
                updatedText = Mid(updatedText, 3)
            ElseIf Left(updatedText, 1) = vbLf Then
                updatedText = Mid(updatedText, 2)
            ElseIf Left(updatedText, 1) = vbCr Then
                updatedText = Mid(updatedText, 2)
            End If

            updatedText = LTrim(updatedText)

            If strInput <> updatedText Then
                rs.Edit
                rs!nass = updatedText
                rs.Update
            End If
        End If

        rs.MoveNext
    Loop

    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set regExp = Nothing

    MsgBox "تمت إزالة الأنماط والسطر الفارغ بنجاح!", vbInformation
    Exit Sub

ErrorHandler:
    MsgBox "حدث خطأ: " & Err.Description, vbCritical
    If Not rs Is Nothing Then
        rs.Close
        Set rs = Nothing
    End If
    Set db = Nothing
    Set regExp = Nothing
End Sub

 

[nssj]

جزاك الله خيرا أخي الكريم وأحسن إليك

تم المطلوب بحمد الله