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

مشاركة مع اخي محمد يمكن الاستعانة بوسيط لإخراج الصور على النحو التالي : افتح البرنامج على عرض التصميم في جزء التنقل : - حدد النموذج الذي يحتوي على صورة خلفية أو تنسيق تلقائي تريده - انقر بزر الماوس الأيمن على النموذج في جزء التنقل وحدد تصدير >> XML في الصفحة الأولى من المعالج ، حدد مكان الحفظ انقر التالي او موافق سيظهر لك مربع حوار صغير به ثلاثة مربعات اختيار قم باختيار الخيار الأول (البيانات) والخيار الثالث (العرض التقديمي) ثم اضغط موافق انقر فوق الزر "إغلاق" في الصفحة الأخيرة من المعالج بعد اكتمال عملية التصدير اذهب الى مكان الحفظ ستجد جميع صورك في مجلد Images

السلام عليكم ورحمة الله وبركاته في هذا الإصدار يوجد ثلاث تطبيقات ( الملف بالمرفقات ) - 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

وعليكم السلام ورحمة الله تعالى وبركاته 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

ولا يهمك أخي @محمد العراقى سنكون سعداء دائما بحصولك على النتائج المطلوبة يكفي تعديل هدا الجزء من الكود 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

جرب هدا بعد تنفيد ما سبق دكره سابقا 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

جرب هدا Dim OnRng(), tbl, Irow, ColVisu(), Dates(), Choix() Private Sub UserForm_Initialize() tbl = "Table2" OnRng = Range(tbl).value For i = 1 To UBound(OnRng): OnRng(i, 2) = CDate(OnRng(i, 2)): Next i Irow = Range(tbl).Columns.Count ColVisu = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12) ListBox1.ColumnCount = 12 Set d = CreateObject("scripting.dictionary") d("*") = "" For i = LBound(OnRng) To UBound(OnRng) d(OnRng(i, 3)) = "" Next i Choix = d.keys '================' رقم السيارة ============== Tri Choix, LBound(Choix), UBound(Choix) Dim iTemp As Variant For i = LBound(Choix) To (UBound(Choix) - LBound(Choix)) \ 2 iTemp = Choix(i) Choix(i) = Choix(UBound(Choix) - i) Choix(UBound(Choix) - i) = iTemp Next i Me.ComboBox1.List = Choix '================' اسم السائق ======================== Set d = CreateObject("scripting.dictionary") d("*") = "" For i = LBound(OnRng) To UBound(OnRng) d(OnRng(i, 4)) = "" Next i Choix = d.keys Tri Choix, LBound(Choix), UBound(Choix) Me.ComboBox4.List = Choix Set d = CreateObject("scripting.dictionary") colDate = 2 For i = LBound(OnRng) To UBound(OnRng) d(OnRng(i, colDate)) = "" Next i Dates = d.keys Tri Dates, LBound(Dates), UBound(Dates) Me.ComboBox2.List = Dates: Me.ComboBox2 = Dates(0) Me.ComboBox3.List = Dates: Me.ComboBox3 = Dates(UBound(Dates)) Filtre End Sub Sub Filtre() Dim tbl() clé = Me.ComboBox1: If clé = "" Then clé = "*" cléLieu = Me.ComboBox4: If cléLieu = "" Then cléLieu = "*" début = CDate(Me.ComboBox2) fin = CDate(Me.ComboBox3) colDate = 2 n = 0 For i = LBound(OnRng) To UBound(OnRng) If OnRng(i, colDate) >= début And OnRng(i, colDate) <= fin And OnRng(i, 3) Like clé And OnRng(i, 4) Like cléLieu Then n = n + 1: ReDim Preserve tbl(1 To Irow, 1 To n) c = 0 For Each K In ColVisu c = c + 1: tbl(c, n) = OnRng(i, K) Next K End If Next i If n > 0 Then Me.ListBox1.Column = tbl Else Me.ListBox1.Clear MsgBox "لم يتم العثور على بيانات مطابقة", vbInformation, "نتائج التصفية" End If End Sub ListBox1.ColumnCount = 12-V2.xlsm

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

Public Function AddAmount(originalAmount As Double) As Double Select Case originalAmount Case Is <= 50 AddAmount = 75 Case 51 To 100 AddAmount = 100 Case 101 To 150 AddAmount = 125 Case Else AddAmount = 0 End Select End Function في الاستعلام يمكن الاستدعاء هكذا: NewAmount: AddAmount([OriginalAmount]) لان الاضافات غير متطابقة يمكن تعديل الوحدة بما يناسبك :: تحياتي

وعليكم السلام ورحمة الله تعالى وبركاته ادا كنت قد إستوعبت طلبك بشكل صحيح فربما هدا سيوفي بالغرض ملاحظة : الملف يتضمن عدة أكواد يجب وضع كل كود في مكانه المناسب في Module1 ضع الأكواد التالية Const a As String = "الرئيسية" Const b As String = "تقرير بالموقع" Const c As String = "تقرير بالمنتج" Public Property Get WS() As Worksheet Set WS = Sheets(a) End Property Public Property Get dest() As Worksheet Set dest = Sheets(b) End Property Public Property Get dest2() As Worksheet Set dest2 = Sheets(c) End Property Sub Run_MainFilter() Call FilterData("J", dest, dest.Range("B2")) Call ApplyBorders(ActiveSheet) End Sub Sub Run_SecondaryFilter() Call FilterData("D", dest2, dest2.Range("B2")) Call ApplyBorders(ActiveSheet) End Sub ' دالة لفلترة البيانات Private Sub FilterData(srcColumn As String, srsWS As Worksheet, Clé As Range) Dim arr() As Variant, dataRange As Range, lastRow As Long Dim Crite As String, ColArr As Long, N As Long, lastCol As Long Crite = Clé.Value lastRow = WS.Cells(WS.Rows.Count, srcColumn).End(xlUp).Row If WS.Range(srcColumn & "3:" & srcColumn & lastRow).Find(Crite, _ LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then MsgBox Crite & " غير موجود", vbExclamation Exit Sub End If Application.ScreenUpdating = False srsWS.Range("A5:J" & srsWS.Rows.Count).ClearContents arr = WS.Range("A3:K" & WS.Cells(WS.Rows.Count, "I").End(xlUp).Row).Value N = 5 For ColArr = 1 To UBound(arr, 1) If arr(ColArr, WS.Range(srcColumn & "1").Column) = Crite Then srsWS.Cells(N, 1).Resize(1, 10).Value _ = Application.Index(arr, ColArr, Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11)) N = N + 1 End If Next ColArr lastCol = srsWS.Cells(5, srsWS.Columns.Count).End(xlToLeft).Column lastRow = srsWS.Cells(srsWS.Rows.Count, "A").End(xlUp).Row srsWS.PageSetup.PrintArea = srsWS.Range("A1", srsWS.Cells(lastRow, lastCol)).Address Application.ScreenUpdating = True End Sub ' تعبئة القائمة المنسدلة تقرير المنتج Sub AddDropdown_Main() Dim Data As Range, destCell As Range Dim lastRow As Long, OnRng As String OnRng = "Dropdown_Main" Set destCell = dest.Range("B2") lastRow = WS.Cells(WS.Rows.Count, "P").End(xlUp).Row Set Data = WS.Range("P2:P" & lastRow) On Error Resume Next ThisWorkbook.Names(OnRng).Delete On Error GoTo 0 ThisWorkbook.Names.Add Name:=OnRng, RefersTo:=Data With destCell.Validation .Delete .Add Type:=xlValidateList, Formula1:="=" & OnRng .IgnoreBlank = True .InCellDropdown = True End With End Sub ' تعبئة القائمة المنسدلة تفرير بالموقع Sub AddDropdown_Secondary() Dim Data As Range, destCell As Range Dim lastRow As Long, OnRng As String OnRng = "Dropdown_Secondary" Set destCell = dest2.Range("B2") lastRow = WS.Cells(WS.Rows.Count, "O").End(xlUp).Row Set Data = WS.Range("O2:O" & lastRow) On Error Resume Next ThisWorkbook.Names(OnRng).Delete On Error GoTo 0 ThisWorkbook.Names.Add Name:=OnRng, RefersTo:=Data With destCell.Validation .Delete .Add Type:=xlValidateList, Formula1:="=" & OnRng .IgnoreBlank = True .InCellDropdown = True End With End Sub ' تسطير البيانات Sub ApplyBorders(wsTarget As Worksheet) Dim lastRow As Long, rng As Range lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then Exit Sub Application.ScreenUpdating = False wsTarget.Range("A5:J100").Borders.LineStyle = xlNone Set rng = wsTarget.Range("A5:J" & lastRow) With rng.Borders .LineStyle = xlContinuous .Color = RGB(0, 0, 0) .Weight = xlThin End With Application.ScreenUpdating = True End Sub وفي حدث ورقة الرئيسية Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim tmp As Object, item As Range, OnRng As Range, ColArr As Range Dim LastRow As Long Application.ScreenUpdating = False If Not Intersect(Target, Me.Columns("D")) Is Nothing Or _ Not Intersect(Target, Me.Columns("J")) Is Nothing Then If Not Intersect(Target, Me.Columns("D")) Is Nothing Then Set ColArr = Me.Range("D3", Me.Cells(Me.Rows.Count, "D").End(xlUp)) Set OnRng = Me.Range("O2:O65000") Else Set ColArr = Me.Range("J3", Me.Cells(Me.Rows.Count, "J").End(xlUp)) Set OnRng = Me.Range("P2:P65000") End If Set tmp = CreateObject("Scripting.Dictionary") For Each item In ColArr If item.Value <> "" Then tmp(item.Value) = "" Next item OnRng.ClearContents If tmp.Count > 0 Then OnRng.Resize(tmp.Count, 1).Value = Application.Transpose(tmp.Keys) End If End If Application.ScreenUpdating = True End Sub في حدث ورقة تقرير بالموقع Private Sub CommandButton1_Click() Call SaveRangeAsPDF End Sub Private Sub Worksheet_Activate() Call AddDropdown_Secondary End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B2")) Is Nothing Then If Me.Range("B2").Value = "" Then _ MsgBox "برجاء إدخال إسم الموقع ", vbCritical: Exit Sub Call Run_SecondaryFilter End If End Sub وفي حدث ورقة تقرير بالمنتج Private Sub CommandButton1_Click() Call SaveRangeAsPDF End Sub Private Sub Worksheet_Activate() Call AddDropdown_Main End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B2")) Is Nothing Then If Me.Range("B2").Value = "" Then _ MsgBox "برجاء إدخال إسم المنتج ", vbCritical: Exit Sub Call Run_MainFilter End If End Sub وأخيرا في موديول جديد الكود الخاص بحفظ الملفات بصيغة PDF Option Explicit Sub SaveRangeAsPDF() Dim WSdest As Worksheet, sFile As String, folderName As String, sPath As String Dim lastRow As Long, lastCol As Long, pdfPath As String Set WSdest = ActiveSheet sFile = WSdest.Name folderName = "ملفات PDF" sPath = ThisWorkbook.Path & Application.PathSeparator & folderName & Application.PathSeparator On Error Resume Next If Len(Dir(sPath, vbDirectory)) = 0 Then MkDir sPath On Error GoTo 0 lastRow = WSdest.Cells(WSdest.Rows.Count, "A").End(xlUp).Row lastCol = WSdest.Cells(5, WSdest.Columns.Count).End(xlToLeft).Column WSdest.PageSetup.PrintArea = WSdest.Range("A1", WSdest.Cells(lastRow, lastCol)).Address With WSdest.PageSetup .Orientation = xlLandscape .PaperSize = xlPaperA4 .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 End With pdfPath = sPath & sFile & ".pdf" WSdest.ExportAsFixedFormat Type:=xlTypePDF, fileName:=pdfPath, Quality:=xlQualityStandard MsgBox "تم حفظ الملف بنجاح", vbInformation End Sub بالتوفيق ............ جرد المنتج_V2.xlsb

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

وعليكم السلام ورحمة الله تعالى وبركاته ربما هدا ماتقصده بما أنك فاهم الكود سأوضح فقط ما تم تعديله 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

مشاركة معكم احبتي يوجد حل آخر للحماية بشروط ، او هي شرطين : الاول ان من يعمل على البرنامج لا يشمله الحجب ( لأنه حين يكون متصلا بالجدول من داخل البرنامج ، يمكنه نسخه) الثاني ان تكون الحماية على على الحقول النصية في الجدول فقط الطريقة هي تشفير الجدول عند غلق البرنامج سبق لي من زمن ليس بالقريب ان عملت نوت بوك بريمج صغير لتسجيل الاسماء وارقام هواتفهم وبيانات اخرى .. وكان طلب صاحبي ان لا يتمكن احد من قراءة البيانات عند غلق البرنامج . حماية تشفير.mdb

يمكنك دمج الطريقتين مع بعض كما في الصورة ListBox1.ColumnCount = 12-V3.xlsm

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

فى نقطه لازم تكون عارفها اولا يمكن لل PHP الوصول لل Mysql (طبيعيا) (ستطلب معرفة جيده للغة php و css و html) ويمكن للاكسيس الوصول لل mysql ايضا (المحلى) وليس اغلب الاستضافات بسبب الحماية لكن لا يمكن لل php الوصول لقاعدة بيانات اكسيس بالتالى اذا كنت تريد تريد معرفة فكرة لربط الاكسيس مع mysql واستخدام ال php معا يمكن النظر فى هذا الموضوع لكن اذكرك انك بحاجه لكى تفهم لغة php ,css,html واذا وصلت فيهم لمستوي جيد حينها قد تستغني عن الاكسيس تماما والتوجه الى واجهات البرمجه php ف هي عالم اوسع وامكانيته اكبر اتمني ان اكون وضحت لك الافكار واذا كان هناك نقطه لم استوفي الشرح فيها لا تتردد فى سؤالى وان شاء الله اذا كان عندي لك اجابه سوف ارد عليها

تفضل حماية تشفير.mdb

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

السلام علبكم 🙂 بسبب اختلاف تنسيقات ملفات الاكسل (او CSV) ، وخصوصا تلك التي من مواقع وزارة التعليم في المملكة العربية السعودية ، كنا نضطر ان نتعامل بالكود مع كل تنسيق بطريقة تختلف عن الملف الآخر ، مما يجعل الحل لا يتناسب مع التنسيقات الملفات الاخرى ، وهذا الكود ليس بالسهل تعديله. ولكن ، تقريبا جميع مستخدمي الاكسس يعرفون التعامل مع الاستعلام ، لهذا السبب دعونا نتعامل مع بيانات الاكسل في استعلام ، استعلام مسقط 🙂 هذه واجهة النموذج الذي يتم كل شيء عن طريقه: 1. لتصفح الملفات ، واختيار ملف الاكسل (xls, xlsx, xlsm, csv) ، وسيظهر اسم الملف الذي تم اختيارة في الحقل رقم 2 ، 3. ستظهر قائمة بأسماء الاوراق (Sheets) الموجودة في الملف ، ويجب اختيار الورقة المطلوبة ، 4. هذا نموذج جدولي ، و ستظهر بيانات ورقة الاكسل هنا ، ويمكننا التعامل مع فرز وتصفية البيانات هنا ، وبعدة طرق ، 5. سيظهر استعلام مناداة ورقة الاكسل هنا (بدون فرز وتصفية) ، على شكل SQL ، وبأسماء حقول الورقة ، والتي يمكن نسخها لأي قاعدة بيانات خارجية ، 6. سيظهر استعلام مناداة ورقة الاكسل هنا (بدون فرز وتصفية) ، على شكل SQL ، وبدون أسماء حقول الورقة ، والتي يمكن نسخها لأي قاعدة بيانات خارجية ، 7. يجب النقر هنا حتى نرى نتائج الفرز والتصفية كجزء من الاستعلام في الحقول 8 و 9 ، 8. سيظهر استعلام مناداة ورقة الاكسل هنا (بالفرز والتصفية) ، على شكل SQL ، وبأسماء حقول الورقة ، والتي يمكن نسخها لأي قاعدة بيانات خارجية ، 9. سيظهر استعلام مناداة ورقة الاكسل هنا (بالفرز والتصفية) ، على شكل SQL ، وبأسماء حقول الورقة ، والتي يمكن نسخها لأي قاعدة بيانات خارجية ، 10. يمكنك عمل استعلام جاهز (للورقة بدون فرز وتصفية) او جدول ، سواء في قاعدة البيانات هذه ، او اختيار قاعدة بيانات خارجية (يجب ان تكون مغلقة حتى تستطيع تصدير استعلام او جدول لها) ، وسيكون اسم الاستعلام نفس اسم الورقة ، مثلا اسم الورقة ABC ، فيصبح اسم الاستعلام: qry_ABC ، او يكون جدول بإسم tbl_ABC حسب اختيارك من الرقم 11 ، او حتى الحاق بيانات الاستعلام الى جدول موجود سابقا (طبعا يجب مراعاة ان يكون الجدول بنفس حقول الورقة) ، 12. لنسخ الاستعلام الى ذاكرة الكمبيوتر ، بحيث يمكنك استعمال لصق ctrl+v لكائن الاستعلام (انظ الفيديو التوضيحي) ، 13. عادة لا نغير اي شيء هنا. طريقة العمل: . نرى من اعلاه: 1. انه تم عمل استعلام ياسم qry_Sheet1 في قاعدة البيانات الخارجة Testing.accdb ، 2. كذلك نسخنا استعلام التصفة الى ذاكرة الكمبيوتر (تابع في الفيديو التالي) . ممكن خلط عمل الفرز و التصفية بعدة طرق ، منها كما في الفيديو اعلاه ، و الصور التاليه . . لنفتح قاعدة البيانات الخارجية ونرى ما فيها ، هنا نحن نتعامل مع استعلام اكسس عادي ، فيمكننا حذف الحقول التي لا نريدها ، او نخفي اخرى ، او .... . عند فتح قاعدة البيانات الخارجية ، وحصلت على رسالة الخطأ هذه ، فهذا معناه ان برنامج "استعلام مسقط" لايزال مفتوح ، وملف الاكسل مفتوح به ، لذا يجب اغلاق برنامج "استعلام مسقط" قبل استعمال ملف الاكسل : . البرنامج يتعامل مع ملف واحد فقط ، ويعمل له استعلام ، واذا اردنا ان نتعامل مع اكثر من ورقة اكسل ، فيمكننا عمل مجموعة من استعلامات ، ثم نعمل امر لتنفيذها واحدة تلو الاخرى ، وبما انه عندنا استعلام ، فيمكننا تحويله الى جميع انواع الاستعلامات ، سواء استعلام الحاق ، او استعلام اضافة ، او استعلام لعمل جدول. هناك عدة ميزات في استعمال هذه الطريقة عن ربط الاكسل كجدول : 1. اسرع بكثير ، 2. عند استيراد كائنات قاعدة البيانات الى قاعدة اخرى ، فالاكسس يتوقف كثيرا عند الجداول الاكسل المرتبطة ، بينما لا يأخذ اي وقت لهذا الاستعلام 3. اختار الحقول اللي تريدها فقط ، جعفر Muscat_Query.zip

السلام عليكم لا مشكلة في الكود قمت بنجربة الكود على النص العربي يملفك والكود شغال 100% الكود يتعامل مع الحروف الإنجليزية والعربية، لأن دالة Split وخصائص Characters وFont.ColorIndex تعمل مع جميع النصوص، بغض النظر عن اللغة الدالة Len تعمل مع جميع النصوص بغض النظر عن اللغة، سواء كانت النصوص مكتوبة باللغة العربية، الإنجليزية، أو أي لغة أخرى. فهي ببساطة تُرجع عدد الأحرف في النص، ولا تهتم بنوع الأحرف أو اللغة المستخدمة. وطريقة عمل التلوين حيت تقوم بتحديد النص المراد تلوبن احد حروفه او اكثر من حرف ثم تكتب الحرق في الصندوق inputbox قيتم تلوبن النص بالتوفيق

تفضل أخي الكريم تم عمل زر لسهولة التلوين . اختر الخلايا أولا ثم اضغط على الزر و أكتب حروف أو كلمات سواء عربي أو انجليزي و سيقوم بتلوينها تلوين حروف.xlsm

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) قمت بتنفيذ فكرة تعقب التغييرات بين الجداول والمبنية على فكرة الأستاذ @ابو البشر ( مشكوراً ) مع إجراء بعض التعديلات ، بحيث تم منح المستخدم الحرية في اختيار جدولين ومفتاح ربط أساسي و مشترك فيما بينهم بشكل بسيط وسهل ، ولا يحتاج الأمر لأي مكتبات أو دعم خارجي . ⭐ ما احتجنا له هو كومبوبوكس عدد 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 وهذه صورة للبرنامج :-

السلام عليكم ورحمة الله وبركاته الاخ / محمد هشام الله يعطيك العافية وشكرا لكم على حسن تعاونكم وتعاملكم ومجهوكم المثمر في تحقيق ما نريد والشكر موصول للجميع واسأل الله لنا ولكم التوفيق والسداد وان يجعلها في ميزان حسناتكم وجزاكم الله خيرا وارجو المعذرة منكم على الازعاج

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

السلام عليكم و رحمة الله صراحة لم اطلع على الملف الثانى ارجو ان يكون هذا الكود التالى هو المقصود ملحوظة : قم بانشاء ورقة جديدة سمها Colln Sub Collection() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, LS As Long Set ws = Sheets("Colln") LR = ws.Range("F" & Rows.Count).End(3).Row For Each Sh In Worksheets(Array("أدب عربي1", _ "أدب عربي2", "أدب عربي3", "أدب عربي4")) LS = Sh.Range("F" & Rows.Count).End(3).Row Sh.Range("A1:I" & LS).Copy ws.Range("A" & LR).PasteSpecial xlPasteAll LR = LR + LS Next Application.CutCopyMode = False End Sub

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

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

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

لا يتم تكرار الأرقام .. فالكود يعيد ترقيم حقل ال ID تصاعديا كل مرة ..

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

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

لمعرفة إذا كانت قاعدة الحالية تعمل من موقع موثوق أم لا فيمكن تطبيق الأمر التالي ? 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

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

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

أخي الكريم اهلاً وسهلاً بك معنا .. من وجهة نظري اعتقد أن اعدادات الطباعة قد تختلف بحسب التقرير الذي تريد طباعته ، فعادةً اكسيس يقوم بانشاء تقرير مع افتراض حجم الورق = Letter كما في الصورة أدناه ، في النقطة 2 . وحتى أنه يفترض اتجاه الورقة = بشكل طولي كما في النقطة 1 . أيضاً يقوم باختيار الطابعة الإفتراضية بشكل تلقائي للتقارير كما في النقطة 3 ,, وعليه فإنه وحسب حاجتك في تقريرك ( اختيار اتجاه الورقة = " طولي " أو " عرضي " ) وحجم الورقة = A4 أو A3 ... إلخ . وتحديد الطابعة لكل تقرير . فمثلاً لو كان التقرير هذا يطبع ملصق باركود مثلاً ويوجد طابعة لهذا النوع من الملصقات فيتم اختيارها لهذا التقرير . وإذا كنت في تقرير آخر تريد طباعة معلومات بحجم الورقة العادية = A4 فتختار نوع الطابعة لهذا التقرير بشكل منفصل . وطبعاً هنا في هذه النقطة سيكون الأمر أكثر توسعاً من مجرد اختيار طابعة لكل تقرير دون تحديد اسمها في كود الطباعة ( إن لم تخني معلومتي ) هذا بالنسبة لما تفضلت به في استفسارك .. والله اعلم هي فقط وجهة نظر

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

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

وبار ك فيكم شكرا لك اخ حسونة والاخ أبو مروان

وعليكم السلام ورحمة الله وبركاته كود ترحيل التغيير من الوصل الى السجل.xlsm

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

مشاركة مع الاخوة ..... انظر هذا .... ADD (1).accdb

جملتك هذه فهمت منها من كلمة نفس الحقول اي اتركها كما هي نتائج المقارنة.xlsb نتائج المقارنة1.xlsb

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

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

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

أخي @عذاب الزمان بعد الاطلاع على مرفقك وجدت أنك معتمد على حقل ال ID بشكل أساسي .. لذلك غيرت المنهجية وعملته لك بشكل يلائم مرفقك .. نفضل : 🙂 ADD.accdb

لدي فكرة أستخدمتها في عدة برامج .. 🙂👌 إضافة حقل رقمي من نوع Doble مزدوج ونسميه Order مثلا .. وهو حقل خاص بالترتيب ( ترتيب ظهور السجلات ) بحيث يتم ترتيب السجلات بناءا على هذا الحقل.. ويأخذ قيمته تلقائيا بعد إدراج السجل .. ثم بعد ذلك تتغير قيمته حسب موقعه المطلوب بين السجلات .. بحيث تضيف 0.001 مثلا لقيمة السجل المراد أن يكون هذا السجل بعده ليأخذ موقعه المناسب .. وبهذا نستطيع التحكم بترتيب السجلات بدون التأثير على حقل المفتاح الأساسي

السلام عليكم ايضا انا لدي تساؤل ؟؟ كيف تضع الرقم المطلوب داخل النموذج بمعنى : كيف تعرف مرتبة الرقم الذي ستضيفه .. بمعنى اوضح كيف عرفت ان الرقم المناسب هو 9 ؟ ماهي معاييرك ؟ الحل برأيي : ان اعادة الترقيم يكون منفصل عن الادخالات يتم الترقيم التلقائي بناء على التاريخ الذي يتم فرزه من الأقدم الى الأحدث يمكنك اعادة الترقيم في اي وقت سواء ادخلت بيانات ام لم تدخل ADD2.rar

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

السلام عليكم 🙂 في الواقع انا خسارتي كبيرة لغيابي عن المنتدى لفترات طويلة ، لأني ما اشوف و اواكب واتعلم واستفيد من مثل هذه الابداعات الجميلة 🙂 شكرا لك اخوي ابو جودي 🙂 جعفر