نجوم المشاركات

تفضل ..... الكود لنقل الرقم فقط ...اعلمنا بالنتيجة .... 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

الأخ @TAMER AGOOR جرب الحل الموجود في هذا الموضوع

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

السلام عليكم ورحمة الله وبركاته اليوم اقدم لك وظيفة مُطَهَّرُ النُّصُوصِ الْعَرَبِيَّةِ غاية فى الروعة ومكتوبة بعناية واحترافية للحصول على اكبر قدر ممكن من الدقة فى الاداء والمرونة فى التناول عند الاستدعاء حيث أن الكود يعالج النصوص العربية بطريقة مرنة مع التركيز على ازالة المسافات وتنظيف النص و إزالة التشكيل و توحيد الاحرف ومعالجتها يعتمد الكود خيارين للعمل (إزالة المسافات أو التطبيع "توحيد الاشكال المختلفة للاحرف" ) مما يجعله قابلاً للتخصيص بناءً على الحاجة على سبيل المثال النص الاصلى والذى نريد معالجته : "تَجْرِبَةُ إِشْرَافٍ عَلَى? بَعْضِ الْأَمَاكِنِ أَوْ الْمَكَانِ رَقْمٌ 101" الحالات التى يمكن الحصول عليها من معالجة النص السابق هى ازالة المسافات فقط وتنظيف النص مع الابقاء على الارقام بدون التطبيع : تجربة إشراف على بعض الأماكن أو المكان رقم 101 ازالة المسافات وتنظيف النص مع الابقاء على الارقام مع التطبيع : تجربه اشراف علي بعض الاماكن او المكان رقم 101 ازالة المسافات وتنظيف النص مع ازالة الارقام مع التطبيع : تجربه اشراف علي بعض الاماكن او المكان رقم ازالة المسافات فقط وتنظيف النص مع ازالة الارقام بدون التطبيع : تجربة إشراف على بعض الأماكن أو المكان رقم الكود ' Function: ArabicTextSanitizer ' Purpose: Sanitizes Arabic text by removing non-Arabic characters, optionally normalizing the text, ' removing diacritics (harakat), and optionally removing numeric characters or spaces. ' Parameters: ' inputText (String): The Arabic text to be sanitized. It can contain Arabic characters, non-Arabic characters, ' diacritics, and numeric values. ' normalize (Boolean): Optional. If True, the text will be normalized by replacing specific Arabic characters ' with their standardized equivalents (default is True). ' RemoveNumbers (Boolean): Optional. If True, numeric characters (0-9) will be removed from the text (default is True). ' removeSpaces (Boolean): Optional. If True, all spaces in the text will be removed (default is False). ' Returns: ' String: The sanitized Arabic text with optional normalization, removal of numbers, and spaces. ' ' Example Use Cases: ' 1. Remove spaces only and clean the text while keeping numbers without normalization: ' ' Removes spaces from the text while keeping numbers and without normalizing the text. ' ' Example: ArabicTextSanitizer(inputArabicText, False, False, True) ' ' 2. Remove spaces and clean the text while keeping numbers and normalizing: ' ' Normalizes the text and removes spaces, while keeping numbers. ' ' Example: ArabicTextSanitizer(inputArabicText, True, False, True) ' ' 3. Remove spaces and clean the text while removing numbers and normalizing: ' ' Normalizes the text, removes spaces, and removes numbers. ' ' Example: ArabicTextSanitizer(inputArabicText, True, True, True) ' ' 4. Remove spaces only and clean the text while removing numbers without normalization: ' ' Removes spaces and numbers, but does not normalize the text. ' ' Example: ArabicTextSanitizer(inputArabicText, False, True, True) ' Public Function ArabicTextSanitizer(inputText As String, Optional normalize As Boolean = True, Optional RemoveNumbers As Boolean = True) As String On Error GoTo ErrorHandler ' Ensure the input is valid (non-empty and not null) If Nz(inputText, "") = "" Then ArabicTextSanitizer = "" Exit Function End If ' Initialize the sanitizedText with the trimmed input Dim sanitizedText As String sanitizedText = Trim(inputText) ' Step 1: Normalize the text if requested If normalize Then ' Define character replacement pairs for normalization Dim charReplacementPairs As Variant charReplacementPairs = Array( _ Array(ChrW(1573), ChrW(1575)), _ Array(ChrW(1571), ChrW(1575)), _ Array(ChrW(1570), ChrW(1575)), _ Array(ChrW(1572), ChrW(1608)), _ Array(ChrW(1574), ChrW(1609)), _ Array(ChrW(1609), ChrW(1610)), _ Array(ChrW(1577), ChrW(1607)), _ Array(ChrW(1705), ChrW(1603)), _ Array(ChrW(1670), ChrW(1580))) ' Apply replacements for character normalization Dim pair As Variant For Each pair In charReplacementPairs sanitizedText = Replace(sanitizedText, pair(0), pair(1)) Next ' Step 2: Remove diacritics (harakat) from the text Dim diacritics As String diacritics = ChrW(1600) & ChrW(1611) & ChrW(1612) & ChrW(1613) & ChrW(1614) & ChrW(1615) & ChrW(1616) & ChrW(1617) & ChrW(1618) Dim i As Integer For i = 1 To Len(diacritics) sanitizedText = Replace(sanitizedText, Mid(diacritics, i, 1), "") Next End If ' Step 3: Retain only Arabic characters, spaces, and optionally numbers Dim tempChars() As String Dim charIndex As Long Dim intChar As Integer Dim finalResultText As String ' Iterate through each character in the sanitized text For i = 1 To Len(sanitizedText) intChar = AscW(Mid(sanitizedText, i, 1)) ' Check for Arabic characters (range for Arabic characters and spaces) If intChar = 32 Or _ (intChar >= 1569 And intChar <= 1594) Or _ (intChar >= 1601 And intChar <= 1610) Or _ (intChar >= 1648 And intChar <= 1649) Then ReDim Preserve tempChars(charIndex) tempChars(charIndex) = ChrW(intChar) charIndex = charIndex + 1 ' Optionally, check for numbers if RemoveNumbers is False ElseIf Not RemoveNumbers And (intChar >= 48 And intChar <= 57) Then ReDim Preserve tempChars(charIndex) tempChars(charIndex) = ChrW(intChar) charIndex = charIndex + 1 End If Next ' Step 4: Join the valid characters into a final result text finalResultText = Join(tempChars, "") ' Step 5: Remove extra spaces (multiple consecutive spaces replaced with a single space) finalResultText = Replace(finalResultText, " ", " ") ' Improved space replacement Do While InStr(finalResultText, " ") > 0 finalResultText = Replace(finalResultText, " ", " ") Loop ' Step 6: Remove special characters (if needed) finalResultText = Replace(finalResultText, "*", "") finalResultText = Replace(finalResultText, "#", "") finalResultText = Replace(finalResultText, "@", "") finalResultText = Replace(finalResultText, ",", "") ' Return the sanitized text If Len(Trim(Nz(finalResultText, ""))) = 0 Then ArabicTextSanitizer = vbNullString Else ArabicTextSanitizer = finalResultText End If Exit Function ErrorHandler: Debug.Print "Error in ArabicTextSanitizer: " & Err.Description ArabicTextSanitizer = "" End Function وهذه الوظيفة تبين اشكال وطرق الاستدعاء المختلفة ' Subroutine: TestArabicTextSanitizer ' Purpose: Demonstrates and validates the functionality of the ArabicTextSanitizer function. ' It shows various test cases for sanitizing Arabic text with diacritics, non-Arabic characters, and numbers. Sub TestArabicTextSanitizer() ' Declare input and result variables Dim inputArabicText As String Dim result As String ' Example input text with diacritics, non-Arabic characters, and numbers inputArabicText = "تَجْرِبَةُ * فَاحِصِهِ # @ , لِعَمَلٍ أَلِكَوَّدِ فِىَّ شَتِّيَّ 3ألْإِشْكآل " & _ "إِشْرَافٍ عَلَى? بَعْضِ الْأَمَاكِنِ أَوْ الْمَكَانِ رَقْمٌ 5 و الْمَكَانِ رَقْمٌ 100100ِ لمعرفة كيف سيعمل ها ألكود" ' Display the original input Arabic text Debug.Print "Input Arabic Text: " & inputArabicText ' Test case 1: Remove diacritics without normalization ' This case removes diacritics (harakat) without altering normalization or removing numbers result = ArabicTextSanitizer(inputArabicText, False, False) Debug.Print "Filtered Arabic Text (case 1 - Remove diacritics without normalization): " & result ' Test case 2: Normalize and remove diacritics ' This case normalizes the text (e.g., converting similar Arabic characters) and removes diacritics result = ArabicTextSanitizer(inputArabicText, True, False) Debug.Print "Normalized Arabic Text and Removed Diacritics (case 2): " & result ' Test case 3: Remove numbers as well (Optional argument set to True to remove numbers) ' This case normalizes the text and removes both diacritics and numbers result = ArabicTextSanitizer(inputArabicText, True, True) Debug.Print "Text without Numbers and Normalized (case 3): " & result ' Test case 4: Just remove diacritics without normalization or removing numbers ' This case removes diacritics and numbers, but does not normalize the text result = ArabicTextSanitizer(inputArabicText, False, True) Debug.Print "Text without Diacritics and Numbers (case 4): " & result End Sub واخيرا اليكم مرفق للتجربة Arabic Text Sanitizer.accdb

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

For tmp = 6 To Irow If IsNumeric(SrcWS.Cells(tmp, "A").Value) Then SrcWS.Cells(tmp, "A").ClearContents End If Next tmp مطلوب ترقيم تلقائى لا يتأثر بحذف الصفوف.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Const Clé As String = "1234" ' قم بتعديل الباسوورد بما يناسبك Private Sub Worksheet_Change(ByVal Target As Range) Dim lastRow As Long lastRow = Cells(Rows.Count, "J").End(xlUp).Row ActiveSheet.Unprotect Clé If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing And Target.Columns.Count = 1 Then Application.EnableEvents = False Dim cell As Range For Each cell In Target If cell.Row >= 7 Then cell.Locked = Not IsEmpty(cell.Value) Next cell Application.EnableEvents = True End If ActiveSheet.Protect Clé, UserInterfaceOnly:=True End Sub '================================== Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim lastRow As Long, choose As String: Static OnRng As Range lastRow = Cells(Rows.Count, "J").End(xlUp).Row If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing Then If Not IsEmpty(Target.Value) Then If Target.Locked Then choose = InputBox(": خلية التوقيع محمية الرجاء إدخال كلمة المرور", ":إنتــباه") If choose = Clé Then ActiveSheet.Unprotect Clé If Not OnRng Is Nothing Then OnRng.Locked = True Target.Locked = False Set OnRng = Target ActiveSheet.Protect Clé, UserInterfaceOnly:=True ElseIf choose <> "" Then MsgBox "كلمة المرور غير صحيحة", vbExclamation, "خطأ" End If Else Set OnRng = Target End If Else ActiveSheet.Unprotect Clé Target.Locked = False Set OnRng = Nothing ActiveSheet.Protect Clé, UserInterfaceOnly:=True End If End If End Sub شيت حوافز تجريبى V2.xlsb

سوف أبين اهمية الوظيفة السابقة فى موضوع مستقل وسوف انوه هنا عن هذا الموضوع وذلك لما فيها من فائدة كبيرة و اهمية عظيمة عند استخدام الفرز والتصفيه وعمل البحث داخل البيانات الموضوع >----->> من هنا

وعليكم السلام ورحمة الله وبركاته ارجو ان اكون استوعبت فكرة عمل ملفك قمت بحذف التنسيقات للجداول لان الكود اظهر احطاء الاصناف التي ليس بها مبيعات اي خليتها فارغة لا يرحلها الكود Sub TransferData1() Dim ws As Worksheet Dim lastRow As Long, lastRowJ As Long Dim i As Long Dim found As Range Dim profitMatch As Boolean Dim userResponse As VbMsgBoxResult Set ws = ThisWorkbook.Sheets("ورقة1") lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row userResponse = MsgBox("هل تريد الترحيل؟", vbYesNo + vbQuestion, "تأكيد الترحيل") If userResponse = vbYes Then For i = 5 To lastRow ' التحقق من وجود بيانات في العمود B If ws.Cells(i, "B").Value <> "" Then profitMatch = False lastRowJ = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row Set found = ws.Range("J5:J" & lastRowJ).Find(ws.Cells(i, "A").Value, LookIn:=xlValues, LookAt:=xlWhole) If Not found Is Nothing Then If ws.Cells(i, "E").Value = ws.Cells(found.Row, "N").Value Then ws.Cells(found.Row, "K").Value = ws.Cells(found.Row, "K").Value + ws.Cells(i, "B").Value profitMatch = True End If End If If found Is Nothing Or Not profitMatch Then lastRowJ = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row + 1 ws.Cells(lastRowJ, "J").Value = ws.Cells(i, "A").Value ws.Cells(lastRowJ, "K").Value = ws.Cells(i, "B").Value ws.Cells(lastRowJ, "L").Value = ws.Cells(i, "C").Value ws.Cells(lastRowJ, "M").Value = ws.Cells(i, "D").Value End If End If Next i End If End Sub الملف تقرير مبيعات1.xlsb

بغض الخطوات التي يجب اتباعها قيل تنفيذ الماكرو الجدول يجب ان يكون مستقلاً غن اي خلايا لا علاقة له بها لذلك 1- تم تفريغ الصف رقم 5 من اي شيء واخفاءه (لعدم الكتابة فيه غن طريق الحطأ) 2- تم تفريغ العامودين ( D و L ) من اي شيء واخفاءهما (لعدم الكتابة فيهما غن طريق الحطأ) 3- الماكرو يأخذ بعض الوقت ليكمل عمله (جوالي 10 ثواني -- حسب سرعة الحهاز عندك) لان البيانات كثيرة جداً 4- الصفحات الأحرى موجودة لكن تم اخفائها لمتابعة عمل الماكرو (بكمن اعادة اظهارها) الكود Option Explicit Dim i%, Lr%, k% Dim Filer_Rg As Range Dim Mon_Array(), Itm '++++++++++++++++++++++++++++++++++++++++ Sub ADD_Sheet() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With With Tousi3 Lr = .Cells(Rows.Count, "H").End(3).Row If Lr < 7 Then Exit Sub For i = 7 To Lr If Application.CountIf(.Range("H2:H" & i), _ .Range("H" & i)) = 1 Then ReDim Preserve Mon_Array(k) Mon_Array(k) = .Range("H" & i) k = k + 1 End If Next For i = 7 To Lr If Not Application.Evaluate("ISREF('" & _ .Range("H" & i) & "'!A1)") Then Sheets.Add(, Sheets(Sheets.Count)).Name = _ .Range("H" & i) End If Next End With End Sub '++++++++++++++++++++++++++++++++++++++++ Sub Filter_Please() ADD_Sheet Dim Rg As Range, Ro% Tousi3.AutoFilterMode = False Set Filer_Rg = Tousi3.Range("E6").CurrentRegion For Each Itm In Mon_Array Sheets(Itm).Range("B3").CurrentRegion.Clear Filer_Rg.AutoFilter 4, Itm Filer_Rg.SpecialCells(12).Copy With Sheets(Itm).Range("B3") .PasteSpecial (8) .PasteSpecial (11) End With Set Rg = Sheets(Itm).Range("B3").CurrentRegion Ro = Rg.Rows.Count If Ro > 1 Then With Sheets(Itm).Range("A4").CurrentRegion .Cells(2, 1).Resize(Ro - 1).Value = _ Evaluate("Row(1:" & Ro - 1 & ")") .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 35 .Rows(1).Interior.ColorIndex = 6 End With End If Next Tousi3.AutoFilterMode = False Tousi3.Select With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق marwa41.xlsm

marwa41 أين الضغط على الإعجاب لهذه الإجابة الممتازة واعتقد ان هذا اقل ما يقدم لصاحب الفضل بعد ربنا فى حل مشكلتك ؟!!!💙

ما شاءا الله يجعله الله فى ميزان حسناتكم

بعد اذن اخي الرائد لا ضرورة لكل هذه الحلفات التكرارية (بدل التنقل داخل النطاق المطلوب نقله خلية خلية ) انسخ النطاق كاملاُ الى الخلية الهدف لاحظ هذا الكود Option Explicit Sub My_code_1() Dim CRow%, jRow%, HowMany% Dim rng As Range Dim I As Worksheet, S As Worksheet Set I = Sheets("INV"): Set S = Sheets("SLS") Set rng = Sheets("INV").Range("c14:c23") HowMany = Application.CountA(I.Range("c14").Resize(10)) CRow = S.Range("C1048576").End(xlUp).Row + 1 jRow = S.Range("J1048576").End(xlUp).Row + 1 CRow = Application.Max(jRow, CRow) I.Cells(14, "C").Resize(HowMany, 5).Copy S.Cells(CRow, "c").PasteSpecial (12) I.Range("G24:G27").Copy With S.Cells(CRow + HowMany, "J") .PasteSpecial (12), Transpose:=True .Resize(, 4).Interior.ColorIndex = 6 End With S.Cells(CRow, "H") = I.Cells(8, "D") S.Cells(CRow, "I") = I.Cells(7, "D") I.Range("C14:C23").ClearContents I.Range("D8").ClearContents Application.CutCopyMode = False End Sub الملف مرفق Salim_Book.xlsm

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

ابسط شئ لحضرتك ان يجعله الله فى ميزان حسناتك هذا العلم بسم الله مشاء الله