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

ولا يهمك أخي @محمد العراقى سنكون سعداء دائما بحصولك على النتائج المطلوبة يكفي تعديل هدا الجزء من الكود For j = LBound(DaysArr) To UBound(DaysArr) For i = 0 To 7 ' الحصص dest.Cells(Irow, i + 2).Value = WS.Cells(OnRng.Row, cnt + i).Value ' المواد If WS.Cells(OnRng.Row + 1, cnt + i).Value <> "" Then dest.Cells(Irow + 1, i + 2).Value = WS.Cells(OnRng.Row + 1, cnt + i).Value End If Next i cnt = cnt + 8 Irow = Irow + 2 Next j اجر-V2.xls

السلام عليكم ورحمة الله وبركاته في هذا الإصدار يوجد ثلاث تطبيقات ( الملف بالمرفقات ) - awsReg_Colorize_VBE لتلوين محرر الأكواد - awsReg_HyperLink_Warning لتفعيل وتعطيل [ application.FollowHyperlink warning ] تم شرح وإضافة الأكواد بالمشاركة التالية بالموضوع الأول الرابط من هنا - awsReg_User_Trusted_Helper_MOD للتحكم بالمواقع الموثوقة Trusted Locations التطبيق الأول : تلوين محرر الأكواد يوجد بعض الأدوات المجانية التي تتيح التعديل علي ألوان محرر الأكواد وتعتمد فكرتها علي التعديل في ملف الـ VBA{Ver}.dll مثال : https://github.com/gallaux/VBEThemeColorEditor ولكن يمكن تحقق نفس النتيجة يدوي او من خلال إضافة قيم للريجيستري يدوي : عن طريق الأكواد إضافة القيم التالية للريجيستري في المسار (HKEY_CURRENT_USER\Software\Microsoft\VBA\7.1\Common) 7.1 هو رقم الاصدار وقد يختلف وتم إضافة المسارات المتوقعة بالاكواد CodeForeColors | CodeBackColors | FontFace | FontHeight | FontCharSet طريقة الإستخدام :call setUpVbeColors(awsDark3) ملحوظة : عند اختيار الخط يفضل اختار ما يدعم اللغة العربية إذا كنت تريد إضافة تعليقات باللغة العربية كما يجب التاكد من الأحجام المتاحة فبعض الخطوط تتيح أحجام محددة مثال بانتظار مشاركة إبداعتكم التطبيق الثالث : إضافة مسار البرامج الخاصة بك في المواقع الموثوقة Trusted Locations لماذا يفضل إضافة المسار الخاص ببرنامجك إلي المواقع الموثوقة ؟ 1- الحد من ظهور التحذيرات أثناء عمل البرنامج وعند كل تشغيل 2- والأهم هي سرعة عمل الأكود فوفق دراسة قام بها بعض المبرمجين فإن الأكود تعمل بشكل أسعر يصل إلي 23× رابط المصدر من هنا اقتباس من المصدر : هل يوجد مكان واحد للإضافة ؟ لا يوجد أكثر من مكان للضافة ولكل مكان ميزاته وعيوبة مثال : فالمسار الخاص بإضافة المواقع الموثوقة لكل برنامج من برامج الاوفيس هو Software\Microsoft\Office\16.0\Access\Security\Trusted Locations ويتغير اسم البرنامج ورقم الإصدار وفق النسخة والبرنامج المستهدف فإذا كان الجذر (ROOT ) هو [ HKEY_CURRENT_USER ] فمن يتأثر بهذه المواقع هو اليوزر الحالي فقط ولكن إن كان [ HKEY_LOCAL_MACHINE] فيتأثر جميع المستخدمين كما ان هناك ترتيب فالموقع داخل HKEY_CURRENT_USER له الأفضلية علي HKEY_CURRENT_USER الموقع الموثوق عبارة عن مفتاح وهو اسم الموقع ويوجد بداخل قيم ويوجد تحت المفتاح الرئيس [Trusted Locations] قيم مثال [USER Trusted Locations Values] : HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Access\Security\Trusted Locations --------------------------------------------- [Value Name ] : AllLocationsDisabled [Value Data ] : False [Value Type ] : REG_DWORD [Value Integer] : 0 [Note ] : All Trusted Locations are Allowed --------------------------------------------- [Value Name ] : AllowNetworkLocations [Value Data ] : False [Value Type ] : REG_DWORD [Value Integer] : 0 [Note ] : All NetWork Locations are Disabled --------------------------------------------- [Locations] : HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Access\Security\Trusted Locations\awsTLocation --------------------------------------------- [Location Name ] : awsTLocation [Location Number] : 02 [Location Values] : [Value Name ] : Path [Value Data ] : D:\AWSTRUSTLOCATION3\ [Value Type ] : REG_SZ ----------------------------------- [Value Name ] : Description [Value Data ] : This Location Has Been Trusted By : AWS REG [Value Type ] : REG_SZ ----------------------------------- [Value Name ] : Date [Value Data ] : 17/11/2024/ 10:41:00 AM [Value Type ] : REG_SZ ----------------------------------- [Value Name ] : AllowSubfolders [Value Data ] : True [Value Type ] : REG_DWORD [Value Integer] : 1 [Note ] : All Sub Folders are Allowed ----------------------------------- --------------------------------------------- فإذا تم تفعيل القيمة [AllLocationsDisabled] تحت المفتاح [Trusted Locations] فهذا يعني تعطيل جميع المسارات الموثوقة تحذير هام: أنصح بعدم وضع المسارات شائعة الاستخدم كسطح المكتب والتنزيلات حتي لا نضعف حماية النظام ملحوظة: أكبر عدد مسموح به للإضافة هو 20 لكل برنامج أوفيس الأمثلة موجودة في مديول : awsReg_Trusted_Locations كما يوجد شرح أيضاً في راس المديول : awsReg_User_Trusted_Helper_MOD تم إضافة تعديل علي الكلاس مديول بإضافة دالة جديدة : allValuesKeysDictColl ------------------------------------------------------------------------------------------- أود الإشارة إلي هذه المقاطع داخل الأكواد لأهميتها 1- داخل الكود loadUserTrusted في هذا الجزء يتم إضافة المسارات الموجودة إلي قاموس ليتم التحقق منها لاحقاً وعلية قد يكون هناك مسار مكرر داخل مفاتيح باسماء مختلفة ولذلك أقوم بحذف الموقع الموثق صاحب المسار المكرر هكذا عالجت الأمر وفق تصوري 2- داخل الكود setUserAppTrustLocation تم تعليق هذا الجزء من الكود لعدم إحتياجي له ويمكنك تفعيله إذا كنت ترد ظهور رسالة في حال تم إيجاد اسم الموقع فإذا اجبت بنعم سيتم تغير المسار داخل الموقع الموجود وإذا أجبت بلا سيتم إضافة _1 لإسم الموقع وإضافة موقع جديد ------------------------------------------------------------------------------------------- يسعدني الإجابة علي استفسارتكم الأكواد متاح للجميع للتعديل والإضافات بالتوفيق winRegApi_OV2.zip

وعليكم السلام ورحمة الله تعالى وبركاته ربما هدا ماتقصده بما أنك فاهم الكود سأوضح فقط ما تم تعديله If Not OnRng Is Nothing Then arr = Array("السبت", "الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس") Irow = 10 cnt = 7 Application.ScreenUpdating = False 'افراغ البيانات السابقة dest.Range("b10:Q21").ClearContents ReDim dataArr(0 To UBound(arr), 0 To 7) For j = 0 To UBound(arr) For i = 0 To 7 dataArr(j, i) = WS.Cells(OnRng.Row, cnt + i).Value Next i cnt = cnt + 8 Next j For j = 0 To UBound(arr) For i = 0 To 7 ' نسخ بيانات اليوم dest.Cells(Irow, i + 2).Value = dataArr(j, i) If IsDate(dest.Cells(Irow, i + 2).Value) Then dest.Cells(Irow, i + 2).NumberFormat = "@" End If ' اظافة اسم المادة في الصف الموالي If dataArr(j, i) <> "" Then dest.Cells(Irow + 1, i + 2).Value = WS.Cells(OnRng.Row, 3).Value End If Next i Irow = Irow + 2 Next j '========== جلب المعلومات الإضافية ============ ' الاسم الرباعي للمعلم' الرقـم القومي ' الفـصــول ' المـــادة' عـدد الحصص المنفذة Dim CellArr As Variant, ColArr As Variant CellArr = Array("E5", "O5", "C6", "H6", "Q6") ColArr = Array(2, 4, 5, 3, 6) For i = LBound(CellArr) To UBound(CellArr) dest.Range(CellArr(i)).Value = WS.Cells(OnRng.Row, ColArr(i)).Value Next i Else MsgBox "لم يتم العثور على تسلسل المعلم " & linge, vbExclamation End If بالتوفيق...... اجر.xls

جرب هدا بعد تنفيد ما سبق دكره سابقا Sub CopyDataOnGroups() Dim lastrow&, r&, Irow& Dim ShtOne As Worksheet, WS As Worksheet Dim rng As Boolean, arr As Variant, tmp As Range Dim lingHeader As Range, cell As Range, data As Variant Dim ColHeader As Range, a As Range, OnRng As Range Dim Group As Boolean, n As Boolean Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set ShtOne = Sheets("التجميع") ShtOne.Range("B3:BD" & ShtOne.Rows.Count).Clear arr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5") For Each sheetName In arr Set WS = Sheets(sheetName) lastrow = WS.Columns("B:BD").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If lastrow < 1 Then GoTo NextSheet For Each lingHeader In WS.Range("B19", WS.Cells(19, WS.Cells(19, Columns.Count).End(xlToLeft).Column)).Cells If lingHeader.MergeCells Then Set lingHeader = lingHeader.MergeArea.Cells(1, 1) For Each tmp In WS.Range(lingHeader.Offset(1, 0), WS.Cells(20, lingHeader.MergeArea.Columns.Count + lingHeader.Column - 1)) Group = False n = False rng = False For Each ColHeader In ShtOne.Range("B1", ShtOne.Cells(1, ShtOne.Cells(1, Columns.Count).End(xlToLeft).Column)).Cells If ColHeader.MergeCells Then Set ColHeader = ColHeader.MergeArea.Cells(1, 1) If Trim(lingHeader.Value) = Trim(ColHeader.Value) Then Group = True For Each a In ShtOne.Range(ColHeader.Offset(1, 0), _ ShtOne.Cells(2, ColHeader.MergeArea.Columns.Count + ColHeader.Column - 1)) If Trim(tmp.Value) = Trim(a.Value) Then n = True Set OnRng = WS.Range(tmp.Offset(1, 0), WS.Cells(lastrow, tmp.Column)) r = ShtOne.Cells(ShtOne.Rows.Count, a.Column).End(xlUp).Row Irow = r + 1 For Each cell In OnRng data = cell.Value If Application.CountIf(ShtOne.Range(ShtOne.Cells(3, a.Column), ShtOne.Cells(r, a.Column)), data) > 0 Then rng = True Exit For End If Next cell If Not rng Then OnRng.Copy ShtOne.Cells(Irow, a.Column).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Application.CutCopyMode = False End If Exit For End If Next a End If If Group And n Then Exit For Next ColHeader Next tmp Next lingHeader NextSheet: Next sheetName Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub المصنف 4.xlsb

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

وعليكم السلام ورحمة الله تعالى وبركاته دالة IF تحتاج إلى شروط واضحة وتنتظر تحديد ما يجب أن يتم في حال كان الشرط صحيحا أو خطأفي حالتك IF "" غير مكتمل لأنك لم تحدد ما يجب تنفيذه في حال كانت الشروط فارغة أو صحيحة إذا كنت تحاول استخدام دالة IF مع FILTER لتحديد قيمة فارغة مثلا عند عدم وجود نتائج في FILTER فيمكنك استخدام دالة IFERROR =IFERROR(FILTER(AP4:AT353, ISNUMBER(SEARCH(AF6, AQ4:AQ353))), "") مع التأكد من أن الفواصل في الصيغة تتناسب مع الاصدار الموجود لديك ; او ,

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Public Property Get WS() As Worksheet Set WS = Sheets("PTT") End Property Public Property Get dest() As Worksheet Set dest = Sheets("Round 5") End Property Private Sub CommandButton1_Click() Dim r As Long, s As Long, t As Long, tmp As Long, ID As String, n As Boolean If Trim(TextBox1.Value) = "" Or Trim(TextBox2.Value) = "" Or _ Not IsNumeric(TextBox1.Value) Or Not IsNumeric(TextBox2.Value) Then MsgBox "الرجاء التحقق من أرقام الإيصالات ", vbCritical Exit Sub End If s = CLng(TextBox1.Value): t = CLng(TextBox2.Value) n = True For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) <> "" Then n = False Exit For End If Next r If n Then MsgBox "لا يوجد أي إيصالات للطباعة على قاعدة البيانات ", vbExclamation Exit Sub End If On Error Resume Next For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) = "" Then GoTo Cnt WS.[d4] = ID WS.[U2] = ID Err.Clear WS.PrintOut If Err.Number <> 0 Then MsgBox "تم إلغاء طباعة الإيصالات", vbExclamation Exit Sub End If Cnt: Next r WS.[aa1] = s WS.[aa2] = t Unload Me End Sub '===================================== Private Sub CommandButton2_Click() Dim r As Long, tmp As Long, s As Long, t As Long, FolderName As String Dim filePath As String, ID As String, n As Boolean, pdfFolder As String If Trim(TextBox1.Value) = "" Or Trim(TextBox2.Value) = "" Or _ Not IsNumeric(TextBox1.Value) Or Not IsNumeric(TextBox2.Value) Then MsgBox "الرجاء التحقق من أرقام الإيصالات ", vbCritical Exit Sub End If s = CLng(TextBox1.Value): t = CLng(TextBox2.Value) n = True For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) <> "" Then n = False Exit For End If Next r If n Then: MsgBox "لا يوجد أي إيصالات للحفظ على قاعدة البيانات ", vbExclamation: Exit Sub FolderName = "الإيصالات" pdfFolder = ThisWorkbook.Path & "\" & FolderName If Dir(pdfFolder, vbDirectory) = "" Then On Error Resume Next MkDir pdfFolder If Err.Number <> 0 Then: Exit Sub On Error GoTo 0 End If For r = s To t tmp = r + 2 ID = dest.Range("B" & tmp).Value If Trim(ID) = "" Then GoTo Cnt End If WS.[d4] = ID: WS.[U2] = ID filePath = pdfFolder & "\invoice_" & ID & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=filePath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Cnt: Next r MsgBox "تم تصدير الملفات إلى مجلد: " & FolderName, vbInformation Unload Me End Sub PTT 2024 v2.xlsm

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

لمعرفة إذا كانت قاعدة الحالية تعمل من موقع موثوق أم لا فيمكن تطبيق الأمر التالي ? CurrentProject.IsTrusted يرجع بـ TRUE إذا كانت تعمل من موقع موثوق أما إذا كان لا فلا يعود بـ False إنما تظهر الرسالة التالية ولذلك تم إضافة الأكواد التالية لمعرفة الحالة هناك إحتمالين 1- ان قاعدة البيانات تعمل من مسار رئيسي مضاف للمواقع الموثوقة 2- ان القاعدة تعمل من مسار فرعي ضمن مسار رئيسي مضافة لموقع موثوق + السماح للمجلدات الفرعي مفعل داخل الموقع AllowSubfolders = 1 لذلك أولاً نحتاج إلي هذه الأكواد ويفضل إضافتها للمديول (Helper_Functions) Public Function isPathOrSub(ByVal basePath As String, ByVal pathToCheck As String) As Boolean Dim sBPath As String Dim sCPath As String sBPath = validTLocPath(Trim(basePath), True) sBPath = Replace(sBPath, "/", "\") sBPath = addTrailSlash(sBPath) sBPath = LCase(sBPath) sCPath = validTLocPath(Trim(pathToCheck), True) sCPath = Replace(sCPath, "/", "\") sCPath = addTrailSlash(sCPath) sCPath = LCase(sCPath) isPathOrSub = (sBPath = sCPath) Or (sBPath = Left(sCPath, Len(sBPath))) End Function Public Function isSubPath(ByVal basePath As String, ByVal pathToCheck As String) As Boolean Dim sBPath As String Dim sCPath As String sBPath = validTLocPath(Trim(basePath), True) sBPath = Replace(sBPath, "/", "\") sBPath = addTrailSlash(sBPath) sBPath = LCase(sBPath) sCPath = validTLocPath(Trim(pathToCheck), True) sCPath = Replace(sCPath, "/", "\") sCPath = addTrailSlash(sCPath) sCPath = LCase(sCPath) isSubPath = (sBPath = Left(sCPath, Len(sBPath))) End Function Public Function isSamePath(ByVal basePath As String, ByVal pathToCheck As String) As Boolean Dim sBPath As String Dim sCPath As String sBPath = validTLocPath(Trim(basePath), True) sBPath = Replace(sBPath, "/", "\") sBPath = addTrailSlash(sBPath) sBPath = LCase(sBPath) sCPath = validTLocPath(Trim(pathToCheck), True) sCPath = Replace(sCPath, "/", "\") sCPath = addTrailSlash(sCPath) sCPath = LCase(sCPath) isSamePath = (sBPath = sCPath) End Function ثانياً يتم إضافة الكود التالي الي المديول (awsReg_User_Trusted_Helper_MOD) Public Function isCurrentLocTrusted(Optional ByVal sPathToCheck As String = "") Dim currentLoc As String Dim i As Long On Error GoTo ErrorHandler resetUserTrusted loadUserTrusted If userDeleteLoc Is Nothing Then Err.Raise vbObjectError + 1001, "isCurrentLocTrusted", "Unable to load user trusted locations or there are none available." End If If Len(Trim(sPathToCheck)) > 0 Then currentLoc = Trim(sPathToCheck) Else currentLoc = GetAppPath() End If For i = 1 To userKeysCount If isSamePath(CStr(userDeleteLoc(i)("locPath")), currentLoc) Then isCurrentLocTrusted = True MsgLog "This Path: [" & currentLoc & "] Is Trusted", llinfo, devDebugP, usrMsgLog Exit For Else If isSubPath(CStr(userDeleteLoc(i)("locPath")), currentLoc) And userDeleteLoc(i)("allowSub") = True Then isCurrentLocTrusted = True MsgLog "This Sub Path: [" & currentLoc & "] Is Trusted", llinfo, devDebugP, usrMsgLog Exit For Else isCurrentLocTrusted = False End If End If Next i ExitAndClean: resetUserTrusted Exit Function ErrorHandler: MsgLog "We Received an Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.Description & vbCrLf & _ "Source : " & Err.Source, _ llCritical, debugState, usrMsgLog isCurrentLocTrusted = False Resume ExitAndClean End Function

أرفق لكم تعديل بسيط حتي يسمح بإضافة مسار كهذا %USERPROFILE%\Desktop\AWSTRUSTLOCATION5\ فكان هدفي من البداية هو توحيد المسارات حتي أستطيع المقارنة ولكن وجدت ان هذا يمنع من تسجيل مسارات في صورتها المتغيرة والقابلة للتمدد وقد يحتاج إليها البعض كما تم إضافة تعديل إذا لفرض حفظ المسار وان لم يكن قابل للتمدد ويكون نوع البيانات الخاصة به هو REG_EXPAND_SZ قد تحتاج إليها في المسارات القصيرة مثل "C:\PROGRA~1" وهو ما يسمي بـ 8.3 Paths ولكي تحصل علي مساراتك الخاصة بعد فتح الـ CMD في الموقع المراد هذا هو الأمر Dir /x وهذا التعديل الذي يسمح بتسجل النص بدلاً من REG_SZ إلي REG_EXPAND_SZ تم أولاً علي الـ awsReg Class Module 1- تم إضافة الكود التالي بالاعلي Private Const FORCE_EXPAND_SZ As String = "awsExpand " Private Const FORCE_EXPAND_SZ As String = "awsExpand " 2- تم التعديل علي VALUE LET PROPERTY بإضافة هذا الجزء ElseIf Left$(CStr(vData), Len(FORCE_EXPAND_SZ)) = FORCE_EXPAND_SZ Then vData = Mid$(vData, Len(FORCE_EXPAND_SZ) + 1) Call RegSetValueEx(hCurKey, ValueName, 0, _ REG_EXPAND_SZ, ByVal CStr(vData), _ Len(vData) + 1) وهنا يتحقق من النص إذا كان يبدأ بـ "awsExpand " سيتم حذفها وتسجيل النص بنوع REG_EXPAND_SZ ثم تم التعديل علي Public Function setUserAppTrustLocation(Optional ByVal locationName As String = "", _ Optional ByVal locationPath As String = "", _ Optional ByVal sDescription As String = "", _ Optional allowSubFolders As Boolean = False, _ -----> Optional forcePathExpandEZ As Boolean = False) As Boolean If forcePathExpandEZ = False Then .value("Path") = sPath Else .value("Path") = "awsExpand " & sPath End If بعد التجربة : تم تسجيل ShortPath بنوع REG_SZ وتم التعرف عليه والتعامل معه بدون مشاكل ما يميز REG_EXPAND_SZ هو تعاملها مع مسارات النظام مثل (%ProgramFiles% - %SystemRoot%) winRegApi_OV2.1.zip

ده فعلا حقيقي رجل محترم بيحب يساعد كل الناس ربنا يجازيه خير

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

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

عمل فورم من خلال موقع chatgptبحث واضافة وحذف وحفظ ومسح فورم بحث واضافة وحذف بيانات بالذكاء الاصطناعي.xlsm

البحث وتعديل درجات8.rar

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

فضلا راجع الوحدة النمطية .. آخر دالتين في الاسفل .. تخص الصفوف الدنيا لا يوجد شيء اسمه : له او لها برنامج علاجي .. ايضا لا يوجد شيء اسمه دور ثاني

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) قمت بتنفيذ فكرة تعقب التغييرات بين الجداول والمبنية على فكرة الأستاذ @ابو البشر ( مشكوراً ) مع إجراء بعض التعديلات ، بحيث تم منح المستخدم الحرية في اختيار جدولين ومفتاح ربط أساسي و مشترك فيما بينهم بشكل بسيط وسهل ، ولا يحتاج الأمر لأي مكتبات أو دعم خارجي . ⭐ ما احتجنا له هو كومبوبوكس عدد 3 ، وزر واحد فقط وظائفهم كالآتي :- cmbTable1 : التعرف على أسماء الجداول في قاعدة البيانات ، وهنا سيكون الجدول الأول . cmbTable2 : التعرف على أسماء الجداول في قاعدة البيانات باستثناء الجدول الذي تم اختياره في cmbTable1 ؛ والهدف هو عمل مقارنة بين جدولين وليس نفس الجدول . cmbPrimaryField : التعرف على أسماء الحقول في الجدول الأول ، ثم يتم اختيار الحقل المشترك أو المفتاح الأساسي من طرف المستخدم . btnExecute : منفّـذ العملية . ⭐ الأحداث والأكواد لكل جزء و عنصر في البرنامج :- في حدث عند التحميل للنموذج ، تم وضع الكود التالي لجلب أسماء الجداول إلى الكومبوبوكس ( cmbTable1 و cmbTable2 ) ، وطبعاً سيتم استثناء جداول النظام والجدول DifferencesTable الذي سيتم إدراج التغييرات فيه ( والذي سيتم انشائه بشكل ديناميكي في قاعدة البيانات عند المستخدم عند عدم وجوده ) . أي أنه وللإستفادة من البرنامج ما عليك إلا نسخ النموذج فقط الى مشروعك . Private Sub Form_Load() Me.cmbTable2.Enabled = False Me.cmbPrimaryField.Enabled = False Dim tdf As DAO.TableDef Me.cmbTable1.RowSource = "" Me.cmbTable2.RowSource = "" For Each tdf In CurrentDb.TableDefs If Left(tdf.Name, 4) <> "MSys" And tdf.Name <> "DifferencesTable" Then Me.cmbTable1.AddItem tdf.Name 'Me.cmbTable2.AddItem tdf.Name End If Next tdf End Sub في حدث بعد التحديث للكومبوبوكس cmbTable1 ، سيتم إدراج أسماء الجداول المتبقية كما ذكرت سابقاً في الكومبوبوكس cmbTable2 باستثناء ما تم اختياره في الجدول cmbTable1 :- Private Sub cmbTable1_AfterUpdate() Dim db As DAO.Database Dim tdf As DAO.TableDef Dim fld As DAO.Field Me.cmbPrimaryField.RowSource = "" Set db = CurrentDb Set tdf = db.TableDefs(Me.cmbTable1.Value) For Each fld In tdf.Fields Me.cmbPrimaryField.AddItem fld.Name Next fld Me.cmbTable2.RowSource = "" For Each tdf In db.TableDefs If Left(tdf.Name, 4) <> "MSys" And tdf.Name <> "DifferencesTable" And tdf.Name <> Me.cmbTable1.Value Then Me.cmbTable2.AddItem tdf.Name End If Next tdf Me.cmbTable2.Enabled = True Set fld = Nothing Set tdf = Nothing Set db = Nothing End Sub في حدث عند النقر على الزر btnExecute ، سيتم تنفيذ الكود التالي :- Private Sub btnExecute_Click() Dim db As DAO.Database Dim rsOld As DAO.Recordset Dim rsNew As DAO.Recordset Dim rsDifferences As DAO.Recordset Dim fld As DAO.Field Dim recordFound As Boolean Dim commonFields As Collection Dim fieldName As Variant Dim primaryField As String Dim table1 As String Dim table2 As String If IsNull(Me.cmbTable1) Then MsgBox "قم باختيار الجدول الأول", vbCritical, "" Me.cmbTable1.SetFocus Exit Sub ElseIf IsNull(Me.cmbTable2) Then MsgBox "قم باختيار الجدول الثاني", vbCritical, "" Me.cmbTable2.SetFocus Exit Sub ElseIf IsNull(Me.cmbPrimaryField) Then MsgBox "قم باختيار الحقل الأساسي", vbCritical, "" Me.cmbPrimaryField.SetFocus Exit Sub Else table1 = Me.cmbTable1.Value table2 = Me.cmbTable2.Value primaryField = Me.cmbPrimaryField.Value If IsNull(table1) Or IsNull(table2) Or IsNull(primaryField) Then MsgBox "Please select both tables and the primary field." Exit Sub End If Set db = CurrentDb If Not TableExists("DifferencesTable") Then CreateDifferencesTable db End If Set rsOld = db.OpenRecordset(table1) Set rsNew = db.OpenRecordset(table2) Set rsDifferences = db.OpenRecordset("DifferencesTable", dbOpenDynaset) DoCmd.SetWarnings False DoCmd.RunSQL "DELETE FROM DifferencesTable;" DoCmd.SetWarnings True Set commonFields = New Collection For Each fld In rsOld.Fields On Error Resume Next If Not IsNull(rsNew.Fields(fld.Name).Name) Then If fld.Name <> primaryField Then commonFields.Add fld.Name, fld.Name End If End If On Error GoTo 0 Next fld Do While Not rsOld.EOF recordFound = False rsNew.MoveFirst Do While Not rsNew.EOF If rsOld(primaryField) = rsNew(primaryField) Then recordFound = True For Each fieldName In commonFields If Nz(rsOld(fieldName), "") <> Nz(rsNew(fieldName), "") Then rsDifferences.AddNew rsDifferences("ID") = rsOld(primaryField) rsDifferences("ChangeType") = "Modification" rsDifferences("FieldName") = fieldName rsDifferences("OldValue") = rsOld(fieldName) rsDifferences("NewValue") = rsNew(fieldName) rsDifferences.Update End If Next fieldName Exit Do End If rsNew.MoveNext Loop If Not recordFound Then rsDifferences.AddNew rsDifferences("ID") = rsOld(primaryField) rsDifferences("ChangeType") = "Deletion" rsDifferences("FieldName") = "عمليات الحذف أو الإضافة" rsDifferences("OldValue") = "عملية حذف" rsDifferences("NewValue") = Null rsDifferences.Update End If rsOld.MoveNext Loop rsNew.MoveFirst Do While Not rsNew.EOF recordFound = False rsOld.MoveFirst Do While Not rsOld.EOF If rsNew(primaryField) = rsOld(primaryField) Then recordFound = True Exit Do End If rsOld.MoveNext Loop If Not recordFound Then rsDifferences.AddNew rsDifferences("ID") = rsNew(primaryField) rsDifferences("ChangeType") = "Addition" rsDifferences("FieldName") = "عمليات الحذف أو الإضافة" rsDifferences("OldValue") = Null rsDifferences("NewValue") = "عملية إضافة" rsDifferences.Update End If rsNew.MoveNext Loop rsOld.Close rsNew.Close rsDifferences.Close Set rsOld = Nothing Set rsNew = Nothing Set rsDifferences = Nothing Set db = Nothing End If CreatePivotQuery table1, table2 MsgBox "تمت عملية المقارنة في الجدولين ، وسيتم فتح الاستعلام بالنتائج", vbInformation, "" DoCmd.OpenQuery "Foksh", acViewNormal End Sub الكود يقوم بتنفيذ عملية مقارنة بين بيانات الجدولين ( من خلال اختيار الجدول الأول والجدول الثاني كما ذكرت سابقاً ) في أي قاعدة بيانات للمستخدم . وفيما يلي شرح مبسط للخطوات الرئيسية التي ينفذها هذا الكود ( للفائدة ):- التحقق من القيم في الكومبوبوكسات الثلاثة يتم التحقق مما إذا كان المستخدم قد اختار الجداول الأساسية ( الجدول الأول و الجدول الثاني ) وحقل المفتاح الأساسي للمقارنة . فإذا كانت أي من هذه المدخلات مفقودة أو لم يتم اختياره ، يعرض الكود رسالة تحذير بوجوب اختيار الجدول أو المفتاح الأساسي وبالتالي يوقف العملية . تحضير البيانات يتم فتح السجلات من الجداول المختارة (الجدول الأول والجدول الثاني) وإنشاء سجل جديد في جدول DifferencesTable لتخزين الفروقات والتغيرات . مقارنة البيانات سيقوم الكود بمقارنة السجلات في الجدولين اللذين تم اختيارهم سابقاً . فإذا كانت السجلات متطابقة في كلا الجدولين ، يتم مقارنة الحقول المشتركة فقط - أي الحقول الموجودة و المتشابهة بالإسم في الجدولين (باستثناء الحقل الأساسي) لتحديد التغييرات . فإذا كانت السجلات مفقودة في أحد الجدولين ( أي تم الحذف أو الإضافة في أي من الجدولين ) ، يتم تحديد نوع التغيير كـ ( عملية حذف ) أو ( عملية إضافة ). إدخال النتائج وإضافتها للجدول DifferencesTable يتم إضافة البيانات الناتجة عن التغييرات ( مثل القيمة القديمة والجديدة ) في جدول DifferencesTable ، مع تسجيل نوع التغيير ( إضافة، حذف، أو تعديل ) . إنشاء استعلام PIVOT أو ما يعرف بالإستعلام Crosstab بعد الانتهاء من المقارنة في الخطوة السابقة ، يتم إنشاء استعلام من نوع Pivot أو Crosstab ( استعلام جدولي كما يسمى في آكسس الواجهة العربية ) ؛ وهو يستخدم لتحويل البيانات من شكل الصفوف إلى شكل الأعمدة ( إن صح التعبير ) ، مما يجعل هذه البيانات أكثر تنظيماً وأسهل في التحليل و القراءةً . والهدف منه هو عرض التغييرات بطريقة منظمة باستخدام الحقول المشتركة بين الجدولين . فتح الاستعلام في نهاية الكود ، يتم فتح الاستعلام الذي يعرض الفروقات والتغيرات بين الجدولين بشكل عادي . ⭐ وظائف أخرى يتم استدعائها لأنشاء الجدول DifferencesTable بعد التأكد من وجوده أو لا . وأخرى لإنشاء الإستعلام الذي يحتوي التغيرات التي تم تعقبها :- وظيفة التأكد من وجود الجدول أو لا :- Function TableExists(tableName As String) As Boolean Dim db As DAO.Database Dim tdf As DAO.TableDef TableExists = False Set db = CurrentDb For Each tdf In db.TableDefs If tdf.Name = tableName Then TableExists = True Exit For End If Next tdf End Function في حال عدم وجود الجدول DifferencesTable ، سيتم استدعاء هذا الـ Sub لإنشائه مع الحقول التي سنحتاجها لعرض البيانات المختلفة في الجدولين :- Sub CreateDifferencesTable(db As DAO.Database) Dim tdf As DAO.TableDef Set tdf = db.CreateTableDef("DifferencesTable") tdf.Fields.Append tdf.CreateField("ID", dbLong) tdf.Fields.Append tdf.CreateField("ChangeType", dbText, 50) tdf.Fields.Append tdf.CreateField("FieldName", dbText, 50) tdf.Fields.Append tdf.CreateField("OldValue", dbMemo) tdf.Fields.Append tdf.CreateField("NewValue", dbMemo) db.TableDefs.Append tdf End Sub بعد تتبع التغيرات والفروقات ، سيتم انشاء استعلام باسم Foksh ، لعرض التغيرات التي تم التعرف عليها :- Sub CreatePivotQuery(table1 As String, table2 As String) Dim queryDef As DAO.queryDef Dim sql As String sql = "TRANSFORM First('" & table1 & " ' & [OldValue] & ' - ' & '" & table2 & " ' & [newvalue]) AS dd " & _ "SELECT DifferencesTable.ID " & _ "FROM DifferencesTable " & _ "GROUP BY DifferencesTable.ID " & _ "PIVOT DifferencesTable.FieldName;" On Error Resume Next CurrentDb.QueryDefs.Delete "Foksh" On Error GoTo 0 Set queryDef = CurrentDb.CreateQueryDef("Foksh", sql) Set queryDef = Nothing End Sub وأخيراً وليس آخراً :- UnMatched.accdb وهذه صورة للبرنامج :-

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