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

وعليكم السلام ورحمة الله تعالى وبركاته بطريقة أخرى Private Sub Worksheet_Change(ByVal Target As Range) Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("Sheet1") Dim n As Object: Set n = CreateObject("Scripting.Dictionary") Dim i As Long, ling As Long, lastRow As Long, tmp As String, kay As String, j As Variant If Not Intersect(Target, WS.Range("A4:B" & WS.Rows.Count)) Is Nothing Then Application.ScreenUpdating = False With WS ' مسح النتائج السابقة .Range("I3:J" & .Rows.Count).ClearContents lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ling = 3 ' تحديد صف وضع النتائج ' بداية من الصف 4 For i = 4 To lastRow tmp = .Cells(i, 1).value ' الحصول على القيمة من عمود A kay = .Cells(i, 2).value ' الحصول على القيمة من عمود B ' التأكد من أن القيم ليست فارغة If tmp <> "" And kay <> "" Then If n.Exists(tmp) Then n(tmp) = n(tmp) & ", " & kay Else n.Add tmp, kay End If End If Next i For Each j In n.Keys .Cells(ling, 9).value = j ' القيم الفريدة في عمود I .Cells(ling, 10).value = n(j) ' القيم المرتبطة في عمود J ling = ling + 1 Next j ' تعديل عرض العمود ليتناسب مع المحتوى .Columns("J").AutoFit End With Application.ScreenUpdating = True End If End Sub TEST CODE.xlsb

السلام عليكم ورحمة الله وبركاته الأخوة الكرام بارك الله فيكم تجدون بالملف المرفق قاعدة بيانات بها - [ awsReg ] وهو Class Module للتحكم بالريجيستري [ Windows Registry ] - [ awsReg_Test_Module ] وهو مديول به نماذج لتوضيح كيفية للإستخدام حاولت قدر المستطاع تغطية جميع الإستخدامات - [ باقي المديولز ] هي ضرورية للعمل نبذة مختصرة - مصدر الكود من هنا : https://learn.microsoft.com/en-us/previous-versions/office/developer/office2000/aa155731(v=office.10)?redirectedfrom=MSDN&ref=nolongerset.com - من قام بتعديل التعريفات لتناسب 64x من هنا : https://nolongerset.com/regop-class-for-64-bit-vba/ - قمت بفضل الله ونعمتة ( الحمد كله لله أوله وأخره) 1- دمج وتجهيز الكود بالكامل 😁 2- تعديل نظام عرض الرسائل والأخصاء بالكامل يدعم اللغة ( العربية - الإنجليزية ) 3- تعديل وظيفة allValue لتعود بي 3D Array القيمة والبيانات ونوعها 4- تعديل وظيفة value لتعود بي 2D array البيانات ونوعها 5- إضافة وظيفة allKeysDict - [Get Property] لتعود بالمفاتيح الفرعية داخل قاموس 6- إضافة وظيفة allValuesDict - [Get Property] لتعود بالقيم الموجودة في مفتاح داخل قاموس 7- إضافة وظيفة IsKeyExists لتعود بنعم إذا كان المفتاح موجود (تم إضافة الـ Api الخاص بها) 8- إضافة وظيفة IsValueExists لتعود بنعم إذا كانت القيمة موجودة 9- التعديل علي بعض الأكواد وإضافة وظائف أخري (قد نأتي لذكرها لاحقاً "إن شاء الله" شرح لمثال واحد [ كتابة قيم داخل الريجيستري ] باقي الأمثلة موجودة بالملف Public Sub Test_awsReg_WriteValues() Dim winReg As awsReg Dim sPath As String Dim sValue As String Dim vResult As Variant On Error GoTo ErrorHandler sPath = "Software\awsApp" ' awsApp Doesn't Exist Yet Set winReg = New awsReg With winReg .useDebug = debugState .useMsgLog = msgLogState .MsgLanguage = englishMsg .Root = HKEY_CURRENT_USER .key = sPath ' REG_SZ Writing a string value .value("MyString") = "Hello, World!" .value("Date") = Format(Now, "yyyy-mm-dd hh:nn:ss") .value("awsPath") = "%USERPROFILE%\Documents" ' REG_DWORD Writing a numeric value [0 For False] [1 For True] .value("isValid") = CInt(1) .value("myNumber") = 2341 .Options = StoreNumbersAsStrings 'this to store numbers as String .value("strNumer") = 5246 ' REG_MULTI_SZ Writing an array (multi-string value) Dim myArray(2) As String myArray(0) = "Value1" myArray(1) = "Value2" myArray(2) = "Value3" .value("MyArray") = myArray Debug.Print "Values written successfully" End With ExitAndClean: If Not winReg Is Nothing Then Set winReg = Nothing Exit Sub ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.description _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Sub النتيجة : الأخوة الكرام الكود متاح للجميع نسعد بتعديلاتكم ومشاركتكم وإستفساركم بالتوفيق winRegApi_V1_FN.zip

أخي الكريم @Foksh شكراً لك علي النصيحة بارك الله فيك أخي الكريم @Moosak أشكرك لك مرورك الطيب كنت بالفعل أنوي تجهيز الأكواد ومشاركتها بمواضيع منفصة ليسهل البحث عنها ولكن تفضل الأكواد التالية للنقطة 1 وإن شاء الله قريباً النقطة 2 روابط للمراجعة : - https://learn.microsoft.com/en-us/microsoft-365/troubleshoot/administration/enable-disable-hyperlink-warning - https://www.slipstick.com/how-to-outlook/disable-unsafe-hyperlink-warning-opening-attachments/ الأكواد بالموديول هي: * hyperLinkWOn - لتفعيل إشعارات الحماية * hyperLinkWOff - لتعطيل إشعارات الحماية * isHyperLinkW - إذا كانت القيمة DisableHyperlinkWarning موجودة بالمسار وتساوي 0 او غير موجودة فهذا يعني ان الحماية مفعلة * msOfficeSecurityPath - لتعود بالمسار المطلوب داخل الريجيستري * awsLink - يقوم هذا الإجراء بتعطيل الحماية ومن ثم فتح الرابط ثم إعادة تفعيلها مرة أخري قمت بالامر هكذا حتي لا نترك الحماية معطلة ولكن يمكن التعديل علي الكود بحيث يتعرف اولاً علي حالة الحماية وإعادتها لحالتها بعد الإنتهاء Option Compare Database Option Explicit Private Const debugState As Boolean = True Private Const msgLogState As Boolean = False Sub Test_awsLink() Dim sPath As String On Error GoTo ErrorHandler sPath = "whatsapp://send/?phone=+2012312313" ' Fisrt Test When The Warning is Enabled hyperLinkWOn ' Make Sure it's Enable Call Application.FollowHyperlink(sPath) ' Second Test When The awsLink it Automatically turnOff then follow The link Then turnOn Again awsLink sPath ExitAndClean: Exit Sub ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.Description _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Sub Public Sub awsLink(ByVal sLink As String) Dim msgRes As VbMsgBoxResult On Error GoTo ErrorHandler hyperLinkWOff ' To Disable The Hyper Link Security Warning If Not (isHyperLinkW) Then Call Application.FollowHyperlink(sLink) Else msgRes = MsgLog("Something Went Wrong" & vbCrLf & _ "We are unable To Disable The Hyper Link Security Warning" & vbCrLf & _ "Do You Want to Continue ?", llQuestion, debugState, msgLogState, , , mbYesNo, db2Second, SecToMs(15)) If msgRes = vbNo Then GoTo ExitAndClean Else Call Application.FollowHyperlink(sLink) End If End If hyperLinkWOn ' To Enable The Hyper Link Security Warning ExitAndClean: Exit Sub ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.Description _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Sub Public Sub hyperLinkWOn() Dim winReg As awsReg Dim sPath As String Dim sValue As String Dim vResult As Variant On Error GoTo ErrorHandler sPath = msOfficeSecurityPath Set winReg = New awsReg With winReg .useDebug = debugState .useMsgLog = msgLogState .MsgLanguage = englishMsg .Root = HKEY_CURRENT_USER .key = sPath .value("DisableHyperlinkWarning") = CInt(0) End With ExitAndClean: If Not winReg Is Nothing Then Set winReg = Nothing Exit Sub ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.Description _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Sub Public Sub hyperLinkWOff() Dim winReg As awsReg Dim sPath As String Dim sValue As String Dim vResult As Variant On Error GoTo ErrorHandler sPath = msOfficeSecurityPath Set winReg = New awsReg With winReg .useDebug = debugState .useMsgLog = msgLogState .MsgLanguage = englishMsg .Root = HKEY_CURRENT_USER .key = sPath .value("DisableHyperlinkWarning") = CInt(1) End With ExitAndClean: If Not winReg Is Nothing Then Set winReg = Nothing Exit Sub ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.Description _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Sub ' isHyperLinkW return True if the DisableHyperlinkWarning is not Exist or = 0 Public Function isHyperLinkW() As Boolean Dim winReg As awsReg Dim sPath As String Dim vResult As Variant On Error GoTo ErrorHandler sPath = msOfficeSecurityPath Set winReg = New awsReg With winReg .useDebug = debugState .useMsgLog = msgLogState .MsgLanguage = englishMsg .Root = HKEY_CURRENT_USER If Not (.IsKeyExists(sPath)) Then GoTo ExitAndClean .key = sPath If .IsValueExists("DisableHyperlinkWarning") = True Then vResult = .value("DisableHyperlinkWarning") ' Debug.Print vResult(0) ' Debug.Print vResult(1) ' Debug.Print CBool(vResult(0)) If CInt(vResult(0)) = 0 Then isHyperLinkW = True Else isHyperLinkW = False End If Else isHyperLinkW = True End If End With ExitAndClean: If Not winReg Is Nothing Then Set winReg = Nothing Exit Function ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.Description & vbCrLf & _ "Source : " & Err.Source _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Function Public Function msOfficeSecurityPath() As String msOfficeSecurityPath = "Software\Microsoft\Office" & "\" & MsAccessVersion() & "\Common\Security" End Function Private Function MsAccessVersion() As String Dim ver As String ver = Application.Version Select Case Left$(ver, 2) Case "16" MsAccessVersion = "16.0" ' Access 2016/2019/365 Case "15" MsAccessVersion = "15.0" ' Access 2013 Case "14" MsAccessVersion = "14.0" ' Access 2010 Case "12" MsAccessVersion = "12.0" ' Access 2007 Case Else MsAccessVersion = ver End Select End Function

بارك الله فيك، ما شاء الله تبارك الرحمن، حل راقي ومميز سلمت وغنمت من ثمار الجنة

وعليكم السلام ورحمة الله تعالى وبركاته اظافة الى ما تقضلو به اساتذتنا الاكارم TEST CODE1.xlsm

شكرا لك أخي @Ahmos (آخر ملوك مصر) 😅🖐 على هذا الجهد الطيب 🙂🌹 أكواد نظيفة ومرتبة ما شاء الله .. رغم قلة معرفتي بكيفية التعامل مع ملفات الريجيستري 😁 لكن لكي تفتح لنا الآفاق هل يمكنك البدء بإعطاء أمثلة عملية على النقطتين [1 - 2 ] مثلا ؟

وعليكم السلام ورحمة الله وبركاته حسب المعادلة في ملفك يمكن استبدالها بمعادلة اخرى لها نفس المهام =SUMPRODUCT(C4:AA4; C$3:AA$3) طبعا لا يمكن لصقها مكان معادلة الصفيف الا بطريقة تظلبل معادلات الصفيف في العمود بالكامل ثم مسح البيانات تم لصق المعادلة الملف المصنف1.xlsx

وعليكم السلام Function JoinUniqueValues(lookupValue As Variant, lookupRange As Range, returnRange As Range) As String Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") Dim i As Long Dim result As String ' إنشاء قاموس لتخزين القيم الفريدة For i = 1 To lookupRange.Count If lookupRange.Cells(i, 1).Value = lookupValue Then If Not dict.exists(returnRange.Cells(i, 1).Value) Then dict.Add returnRange.Cells(i, 1).Value, Nothing End If End If Next i ' دمج القيم الفريدة باستخدام فاصلة result = Join(dict.keys, ", ") JoinUniqueValues = result End Function لاستخدام هذا الكود، قم بإضافته إلى وحدة VBA في Excel، ثم استخدم الدالة في ورقة العمل كالتالي: =JoinUniqueValues(I3, $A$4:$A$1200, $B$4:$B$1200) TEST CODE.xlsm

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

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

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

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

من أسباب عدم نجاح العلاقة بين الجدولين في الصورة .. وجود تكرار في البيانات في الجدول الذي ترغب بجعله مفتاحًا أساسيًا (Primary Key) عند الربط بين جدولين ، يجب أن تكون البيانات في الحقل المرتبط فريدة ( بدون تكرار ) إذا كنت تريد إنشاء علاقة من نوع ( One-to-Many ) . إذا كان هناك تكرار في هذا الحقل ، ستظهر رسالة خطأ . وجود سجلات لا تتطابق بين الجدولين إذا كنت تحاول إنشاء علاقة حيث يجب أن تتطابق القيم بين الجدولين ، ستواجه مشكلة إذا كانت هناك سجلات في أحد الجدولين لا يوجد لها سجلات مقابلة في الجدول الآخر . أنواع بيانات غير متطابقة يجب أن يكون نوع البيانات في الحقول المرتبطة متطابقًا ، مثلًا: إذا كان أحد الحقول "رقم" فيجب أن يكون الحقل الآخر "رقم" أيضًا ، وإلا ستظهر رسالة خطأ . وجود بيانات غير صحيحة أو غير صالحة أحيانًا ، تكون البيانات في الحقول مرتبطة بالقيم الافتراضية أو الحقول المحذوفة ، مما يتسبب في مشكلة عند محاولة الربط . هذا بشكل عام قد يكون أحدها أو معظمها سبباً في عدم نجاح العلاقة بين الجدولين . هذا والله أعلم

وعليك السلام ورحمة الله وبركاته أيها العزيز مستر @Foksh 😊🌹 شكر الله سعيك .. وبارك الله جهدك .. وأحسن الله إليك .. 🙂🌷 إقتراح من مبتديء لسمو معاليك : 👍🏻😁 مع إيماني بكم الإبداع الذي يحويه هذا الجهد .. إلا أني أقترح عليك أن يكون مع هذه الدرة الرائعة إضافة مثال من الجداول والبيانات لكي يتضح للمتابعين والمستفيدين كيفية الاستخدام ونرى صورة مباشرة للنتيجة .. فبالمثال يتضح المقال 😄🖐🏻

Sub CreateShift() Dim lastRow As Long, i As Long, j As Long, kay As String, c As String Dim tbl As Variant, Names As Collection, cell As Range, name As String Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim dest As Worksheet: Set dest = Sheets("Sheet2") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual If Application.WorksheetFunction.CountA(dest.Cells) > 0 Then dest.UsedRange.Clear lastRow = WS.Cells(WS.Rows.Count, 8).End(xlUp).Row tbl = WS.Range("H4:M" & lastRow).Value For i = 1 To lastRow - 3 dest.Cells(1, i + 1).Value = tbl(i, 2) dest.Cells(2, i + 1).Value = tbl(i, 1) If Application.CountA(Application.Index(tbl, i, 3)) > 0 Then Colors dest.Cells(1, i + 1), RGB(200, 200, 255) Colors dest.Cells(2, i + 1), RGB(255, 153, 0) End If Next i Set Names = New Collection On Error Resume Next For i = 1 To UBound(tbl, 1) For j = 3 To 6 If tbl(i, j) <> "" Then Names.Add tbl(i, j), CStr(tbl(i, j)) Next j Next i On Error GoTo 0 For i = 1 To Names.Count dest.Cells(i + 2, 1).Value = Names(i) Next i With dest.Range("A1:A2") .ClearFormats: .Merge: .Value = "ÇáÃÓãÇÁ": .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter: .Font.Bold = True .Borders.LineStyle = xlContinuous: .Borders.color = RGB(0, 0, 255) .Interior.color = RGB(200, 200, 255) End With Dim Hrd As String For i = 1 To lastRow - 3 For j = 1 To Names.Count If Not IsEmpty(dest.Cells(j + 2, 1)) Then name = Names(j) c = dest.Cells(1, i + 1).Value kay = "" For Each cell In WS.Range("J4:M" & WS.Cells(WS.Rows.Count, 10).End(xlUp).Row) If cell.Value = name And WS.Cells(cell.Row, 9).Value = c Then Hrd = WS.Cells(3, cell.Column).Value kay = Hrd Exit For End If Next cell dest.Cells(j + 2, i + 1).Value = kay With dest.Range(dest.Cells(j + 2, 1), dest.Cells(j + 2, i + 1)) .Borders(xlEdgeBottom).LineStyle = xlContinuous .Borders(xlEdgeBottom).color = RGB(0, 0, 255) End With End If Next j Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub New V2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته تفضل أخي سيتم إنشاء مجلد في نفس مسار المصنف بإسم المراكز وحفظ الملفات الجديدة بداخله Public Sub Split_Sheets() Dim fullPath As String, tmp As Collection, rCrit As Variant, Rng As Range, newWb As Workbook Dim AutoFilterWasOn As Boolean, WS As Worksheet, lastRow As Long, cell As Range, s As String Dim Chars As String, i As Integer, col As Integer, f As Worksheet, folder As String Dim fileCount As Integer folder = "المراكز" fullPath = ThisWorkbook.Path & "\" & folder If Dir(fullPath, vbDirectory) = "" Then MkDir fullPath Set WS = ActiveWorkbook.Worksheets("Sheet1") AutoFilterWasOn = WS.AutoFilterMode If AutoFilterWasOn Then WS.AutoFilterMode = False lastRow = WS.Cells(WS.Rows.Count, "D").End(xlUp).Row Set tmp = New Collection On Error Resume Next For Each cell In WS.Range("D3:D" & lastRow) If Not IsNumeric(cell.Value) And Len(cell.Value) > 0 Then tmp.Add cell.Value, CStr(cell.Value) End If Next cell On Error GoTo 0 With Application .ScreenUpdating = False .CopyObjectsWithCells = False .Calculation = xlCalculationManual End With fileCount = 0 For Each rCrit In tmp With WS.Range("B2:H2") .AutoFilter Field:=3, Criteria1:=rCrit End With On Error Resume Next Set Rng = WS.Range("B2:H" & lastRow).SpecialCells(xlCellTypeVisible) On Error GoTo 0 If Not Rng Is Nothing Then Set newWb = Workbooks.Add(xlWBATWorksheet) Set f = newWb.Worksheets(1) s = rCrit Chars = ":\/?*[]" For i = 1 To Len(Chars) s = Replace(s, Mid(Chars, i, 1), "_") Next i If Len(s) > 31 Then s = Left(s, 31) f.Name = s f.DisplayRightToLeft = True Rng.Copy f.Range("B2") For col = 2 To 8 If f.Columns(col).ColumnWidth <> WS.Columns(col).ColumnWidth Then f.Columns(col).ColumnWidth = WS.Columns(col).ColumnWidth End If Next col f.Rows(1).RowHeight = WS.Rows(1).RowHeight Application.DisplayAlerts = False newWb.SaveAs fullPath & "\" & s & ".xlsx", xlOpenXMLWorkbook Application.DisplayAlerts = True newWb.Close False fileCount = fileCount + 1 End If Next rCrit If WS.AutoFilterMode Then WS.AutoFilterMode = False End If With Application .ScreenUpdating = True .CopyObjectsWithCells = True .Calculation = xlCalculationAutomatic End With MsgBox "تم حفظ " & fileCount & " ملفات بنجاح", vbInformation End Sub لقد لاحظت وجود أسماء رقمية في عمود المركز ' في حالة كانت لك رغبة بإنشاء الأوراق الخاصة بها عدل هدا السطر 'من If Not IsNumeric(cell.Value) And Len(cell.Value) > 0 Then 'الى If Len(cell.Value) > 0 Then ترحيل 1 الى شيتات منفصلة v1.xlsb

يعطيك العافية كنت استخدم هذه الطريقة قديما قبل التحول الى ربط كل هذه الامور عن طريق سيرفر و php و بعض اللغات الاخرى طريقة فعالة وجميلة للحماية وكنت قد اضفت ايضا سطر عقابي لكل من يقوم بالتلاعب بالتاريخ الخاص بالجهاز بانقاص يوم من عمر البرنامج عند كل دخول الى البرنامج :: تحياتي

مشاركة مع اخي ابي البشر ان كان هذا ما تريد ؟ )(تغيير رقم الاسبوع ليبدا من 1 .rar

نفضل كود الطباعة سرى الشهادة الاعدادية (2).xlsb

استاذ @Ahmos ☕ يمكن استكمال بنموذج وجدول عند التشغيل يتأكد اذا كان 1 يغير الى 0 لتغير عدد كمثال مسار الملفات يكون مجنون كطول اضافي كأمثله يمكن تطبيقها حماية الجهاز وتمديد وقت الاتصال ونطاق الارقام * مع نموذج آخر يأخذ نسخة كاملة من الرجستري ولاعادة الضبط بجدول 2يمكن تسجيل بعض البيانات كتلميح وشكرا على المرفق ❤️🌹

السلام عليكم حيث ان الأخ محمد من الأصدقاء القدامى .. وقد راسلني .. فهذه المشاركة قد تكون هي الأولى لي في منتدى جيراننا الأكارم مشاركة مع اخي ابي مروان وبعد اذنه يلزم تحديث الخلايا لديك لإزالة حرف الهاء قبل تشغيل الدالة يمكنك نقل الدالة لمحرر الورقة التي تريد تطبيق الكود عليها Sub Utest() Dim urg As Range Set urg = Range("J2:L10") 'غير حسب النطاق لديك Dim UCell As Range For Each UCell In urg UCell.NumberFormat = "@" If UCell.Value = "" Then UCell.Value = "" UCell.Value = Format(UCell.Value, "YYYY/MM/DD") Next End Sub

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Dim PassProtect As String, OnRng As Range Private Const Clé As String = "1234" Public Property Get WS() As Worksheet: Set WS = Sheets("Sheet1"): End Property Sub Data_Protection() Dim linge As Variant Do linge = Application.InputBox("أدخل رقم الصف الأخير لقفل الخلايا", Type:=1) If linge = False Then Exit Sub If Not IsNumeric(linge) Or linge < 1 Or linge > WS.Rows.Count Then: MsgBox "خطأ في الإدخال" Exit Do Loop Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' قم بتعديل النطاق بما يناسبك Set OnRng = WS.Range("A2:M" & linge) With WS If .ProtectContents Then .Unprotect password:=Clé .Cells.Locked = False OnRng.FormulaHidden = True OnRng.Locked = True .Protect password:=Clé End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox linge & ":" & "تم قفل الحسابات بنجاح لغاية الصف ", vbInformation End Sub '======================================================================= Sub Data_UnProtection() Dim result As VbMsgBoxResult Do PassProtect = InputBox("أدخل كلمة المرور لفك الحماية") If PassProtect = "" Then Exit Sub If PassProtect = Clé Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual WS.Unprotect password:=Clé WS.Cells.Locked = False WS.Cells.FormulaHidden = False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم فتح جميع الحسابات بنجاح", vbInformation Exit Sub Else result = MsgBox( _ "كلمة المرور غير صحيحة" & vbNewLine & "هل ترغب في المحاولة مرة أخرى؟", _ vbCritical + vbYesNo, "خطأ في كلمة المرور") If result = vbNo Then MsgBox "تم إلغاء العملية", vbInformation Exit Sub End If End If Loop End Sub غلق المدى المحدد .xlsb

عمر المختار 1 جرب المرفق OK تسلسل .xlsx

هذا ماكرو لاستخراج عبارات بلون محدد آخر الملف مع رقم الصفحة، وهذا أيضا ينفع للفهرسة: On Error Resume Next strFontColor = InputBox(" : اختر لون الخط - رقمه " & vbNewLine & _ vbTab & "تلقائي" & vbTab & vbTab & "0" & vbNewLine & _ vbTab & "أسود" & vbTab & vbTab & "1" & vbNewLine & _ vbTab & "أزرق" & vbTab & vbTab & "2" & vbNewLine & _ vbTab & "أخضر فاتح" & vbTab & "4" & vbNewLine & _ vbTab & "أزرق غامق" & vbTab & vbTab & "9" & vbNewLine & _ vbTab & "أحمر غامق" & vbTab & vbTab & "13" & vbNewLine & _ vbTab & "أصفر غامق" & vbTab & "14" & vbNewLine & _ vbTab & "رمادي 25" & vbTab & vbTab & "16" & vbNewLine & _ vbTab & "رمادي 50" & vbTab & vbTab & "15" & vbNewLine & _ vbTab & "أخضر" & vbTab & vbTab & "11" & vbNewLine & _ vbTab & "قرنفلي" & vbTab & vbTab & "5" & vbNewLine & _ vbTab & "أحمر" & vbTab & vbTab & "6" & vbNewLine & _ vbTab & "نهري" & vbTab & vbTab & "10" & vbNewLine & _ vbTab & "تركواز" & vbTab & "3" & vbNewLine & _ vbTab & "بنفسجي" & vbTab & vbTab & "12" & vbNewLine & _ vbTab & "أبيض" & vbTab & vbTab & "8" & vbNewLine & _ vbTab & "أصفر" & vbTab & vbTab & "7", "قائــــــــــــــمة الألــــــوان") With Selection Dim dic As Object Dim r As Range, k Dim s As String, p As Long Dim Tbl As Table, n As Long Set dic = CreateObject("scripting.dictionary") Set r = ActiveDocument.Content r.Collapse With r.Find .Font.ColorIndex = strFontColor Do While .Execute s = Trim(r.Text) If Len(s) > 1 Then If Not dic.Exists(s) Then Set dic(s) = CreateObject("scripting.dictionary") End If p = r.Information(wdActiveEndPageNumber) dic(s)(p) = Empty End If Loop End With If dic.Count = 0 Then Exit Sub Set r = ActiveDocument.Bookmarks("\EndOfDoc").Range Set Tbl = ActiveDocument.Tables.Add(r, dic.Count, 2) For Each k In dic n = n + 1 Tbl.Cell(n, 1).Range.Text = k Tbl.Cell(n, 2).Range.Text = Join(dic(k).Keys, "، ") Next End With Selection.EndKey Unit:=wdStory Beep End Sub

شيء رائع

اللهم آمين، ولك مثل ذلك

وعليكم السلام ورحمة الله وبركاته ورجب مبارك هذا خط اسمه ثلث ولكنه خط يد وليس خط حاسوب ! 3. تستفيدون من التليغرام https://Telegram.org http://T.me/FonJawi/693 + http://T.me/FonJawi/704 ومن قناتي هناك، أرفع إليكم الملف المرفق لبرنامجنا للخطوط العربية المتحركة الذي يحتوي على هكذا خط متحرك يمتاز بإمكانات قرن الحروف (تداخلها) وتراكبها وتراكيبها ، وتعدد بدائلها وإمكانية استطالة نهاياتها ، وزحزحة نقطها التي تتطلب ميزانًا دقيقًا، علمًا أنه يعمل على النظامين ويندوز وآبل ماكنتوش بنسخها الأخيرة وما قبلها. بالتوفيق وتحياتي لجميع موقع أوفيسنا مع باقة من الورد المحمدي (ورد الجوري) QB-Arabic.pdf