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

اضافة لماتفضل اخي عمر ... اضغط بزر الماوس في التقرير لديك ثم اتبع الصور ....

أخي الكريم هذا لأن الملف من الانترنت وغير موثوق. أغلق الملف واضغط عليه بالمفأرة باليمين Right-click ومن أسفل واجهة General/عام يوجد منطقة اسمها Security وبجانبها أمر Unblock فقط انقر علامة صح عليه وافتحه من جديد.

هل هذا ما تريد ؟ Database1.accdb

جرب هذا الكود بدل الموجود لديك ........................ On Error Resume Next If IsNull(Me.tslsul) Then Me.Undo Me.U1.SetFocus Else If MsgBox("هل تريد الحذف فعلاً ؟", vbYesNo + vbCritical + vbMsgBoxRight + vbDefaultButton2, "تحذير") = vbNo Then Me.U1.SetFocus Exit Sub Else DoCmd.SetWarnings False DoCmd.RunSQL " UPDATE tag1 INNER JOIN hmola ON tag1.byan = hmola.BYAN SET hmola.tag = False;" DoCmd.SetWarnings True DoCmd.SetWarnings False DoCmd.RunCommand acCmdDeleteRecord DoCmd.SetWarnings True Me.Refresh MsgBox "تمت عملية الحذف بنجاح", , "تم" Me.U1.SetFocus End If End If

السلام عليكم و رحمة الله لكى يعمل معك الكود التالى لابد من تطابق البيانات التى فى العمود AP مع رؤوس الاعمدة فى الصف الثالث يمكنك مراجعة ذلك باستخدام علامة = بين الخلية فى الصف الثالث و الخلية فى العمود AP اليك الكود Sub TData() Dim ws As Worksheet, LR As Long Dim C As Range, i As Long Dim x As Integer, y As Double Set ws = Sheets("الايرادات") LR = ws.Range("AP" & Rows.Count).End(3).Row i = 5 Do While i <= LR For Each C In ws.Range("B3:AL3") If ws.Range("AP" & i).Value = C.Value Then x = C.Column + 1 y = ws.Cells(i, x).Value ws.Range("AO" & i).Value = y End If Next i = i + 1 Loop End Sub

تم التخلص من الاستعلامات واستبدالها بعبارة SQL ، وعبارة الـ اس كيو ال مطلوبة بشدة عندما يريد المبرمج أن يبدل نوع رقم الحساب من نصي إلى رقمي. شجرة حسابات_03.rar

الحمد الله رب العالمين واياك اخي محمد

أسأل الله لك و لنا الفرج و راحة البال جزاك الله خيرآ تم الأمر بنجاح 👍

تفضل جرب ............... On Error Resume Next If IsNull(Me.tslsul) Then Me.Undo Me.U1.SetFocus Else If MsgBox("هل تريد الحذف فعلاً ؟", vbYesNo + vbCritical + vbMsgBoxRight + vbDefaultButton2, "تحذير") = vbNo Then Me.U1.SetFocus Exit Sub Else Dim i As Integer, k As Integer 'k = tag1![COU] 'و مهمته هي حساب عدد السجلات لتكرار الكود' ' المربع موجود في النموذج لفرعي Tag1 Me.tag1.SetFocus DoCmd.GoToRecord , , acFirst For i = 1 To [Forms]![Tag]![tag1].Form![COU] DoCmd.SetWarnings False DoCmd.RunSQL " UPDATE hmola SET hmola.tag = false WHERE (((hmola.byan)=[Forms]![tag]![tag1].Form![byan]));" DoCmd.SetWarnings True DoCmd.GoToRecord , , acNext Next i [Forms]![Tag]![esm].SetFocus DoCmd.SetWarnings False DoCmd.RunCommand acCmdDeleteRecord DoCmd.SetWarnings True Me.Refresh MsgBox "تمت عملية الحذف بنجاح", , "تم" Me.U1.SetFocus End If End If

لم افهم ما المقصود ببقية الكود

طيب جرب كودك الان .................... On Error Resume Next If IsNull(Me.tslsul) Then Me.Undo Me.U1.SetFocus Else If MsgBox("هل تريد الحذف فعلاً ؟", vbYesNo + vbCritical + vbMsgBoxRight + vbDefaultButton2, "تحذير") = vbNo Then Me.U1.SetFocus Exit Sub Else Dim i As Integer, k As Integer 'k = tag1![COU] 'و مهمته هي حساب عدد السجلات لتكرار الكود' ' المربع موجود في النموذج لفرعي Tag1 Me.tag1.SetFocus DoCmd.GoToRecord , , acFirst For i = 1 To [Forms]![Tag]![tag1].Form![COU] DoCmd.SetWarnings False DoCmd.RunSQL " UPDATE hmola SET hmola.tag = false WHERE (((hmola.byan)=[Forms]![tag]![tag1].Form![byan]));" DoCmd.SetWarnings True DoCmd.GoToRecord , , acNext Next i DoCmd.SetWarnings False DoCmd.RunCommand acCmdDeleteRecord DoCmd.SetWarnings True Me.Refresh MsgBox "تمت عملية الحذف بنجاح", , "تم" Me.U1.SetFocus End If End If

طيب .. انا على الموبايل ... ارجع ووافيك

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

الحمد لله تقلص الحل إلى سطر واحد فقط 🙂 TreeView1.Nodes("A" & Me.AccID).Selected = True الأخ @محمد القدسي لقد قمت بتنظيم الكود كشكل فقط لتسهيل المراجعة وفهم أدائه. سأجعل هذا المثال لدراسة الشجرة والوصول إلى حلول جديدة إن وجدت. شجرة حسابات_04.rar

اشكرك استاذي AbuuAhmed على هذا الكود الجميل وانا اشهد انك مبدع اخي واستاذي ولاكن لي سؤال اذا تكرمت حاولت افهم هذه الجملة AbsolutePosition في الكود واهميتها ما استطعت فلو تكرمت استاذي شرح مبسط للكود والية عمله وما فائدة زيادة رقم 2 للكود AbsolutePosition وجزاك الله خيرا وبارك فيك وفي اساتذتنا الافاضل

وعليكم السلام ورحمة الله وبركاته ..جرب اخي وضع هدا الكود Sub impr_DocWord_MH() Dim WordApp As Object, worddoc As Object Application.ScreenUpdating = False Set WordApp = CreateObject("Word.Application") 'قم بوضع ملف الوورد في نفس مسار ملف الاكسيل مع تغيير الاسم باسم الملف الخاص بك Set worddoc = WordApp.Documents.Open(ThisWorkbook.Path & "\TEST.docx", ReadOnly:=True) WordAppActiveDocument.PrintOut 'تحديد أرقام الصفحات المراد طباعتها 'WordApp.ActiveDocument.PrintOut Pages:="2" Application.Wait Now + TimeSerial(0, 0, 2) worddoc.Close savechanges:=False WordApp.Quit Set worddoc = Nothing Set WordApp = Nothing Application.ScreenUpdating = True End Sub وفي المرفقات ملف للتجربة طباعة ملف وورد من داخل الاكسيل.rar

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

وعليكم السلام ورحمة الله وبركاته عدل هذا السطر If ws.Cells(r, c + 1).Value2 >= myDate Then ليصبح هكذا If ws.Cells(r, c + 1).Value2 >= myDate and If ws.Cells(r, c + 1).Value2 <= CLng(DateSerial(2019, 1, 1)) Then

الله يجزاكي خيرا والله من امس وانا ادور على حل ..جزاكي الله خيرا

عملت لك حل يفي بالغرض ولكني أعتقد أنه غير مثالي ويمكن يوجد حل أقصر لدى المتمرسين في موضوع الشجرة. حلي عبارة عن استعلامين وشفرة في زر حفظ. شجرة حسابات_02.rar

اليكم اخواني هذا المرفق اخذته من النظام الذي انا اصممه حاليا شجرة حسابات.rar

تفضل اخي Sub SUM_MH() Dim LastRow As Long, i As Long, officena As Long, MH As Long Application.DisplayAlerts = False Last = Cells(Rows.Count, "b").End(xlUp).Row For i = Last To 2 Step -1 If (Cells(i, "b").Value) = "الاجمالي العام" Then Range(Cells(i, "c"), Cells(Rows.Count, 5)).ClearContents End If Next i officena = 1 With ThisWorkbook.Worksheets("البيانات") LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row For i = 1 To LastRow If .Range("b" & i).Value = "اجمالي الموردين" Or .Range("b" & i).Value = "اجمالي العملاء" Then MH = i - 1 .Range("C" & i).Value = Application.Sum(.Range(.Cells(officena, 3), .Cells(MH, 3))) .Range("D" & i).Value = Application.Sum(.Range(.Cells(officena, 4), .Cells(MH, 4))) .Range("E" & i).Value = Application.Sum(.Range(.Cells(officena, 5), .Cells(MH, 5))) .Range("C" & LastRow) = .Range("C" & LastRow) + .Range("C" & i) .Range("D" & LastRow) = .Range("D" & LastRow) + .Range("D" & i) .Range("E" & LastRow) = .Range("E" & LastRow) + .Range("E" & i) officena = i + 1 Application.DisplayAlerts = True End If Next i End With End Sub wor1-3.xlsm

جميعها ممكن ولكن يتطلب بعض التعديل مثلا اذا اردنا ان نعمل على ملف دفعي bat او من خلال vba لابد من بعض التعديلات ولكن لماذا التعقيد فقط افتح المفكرة واحفظ الملف بامتداد reg ليكون الكود ⬇️ Windows Registry Editor Version 5.00 [HKEY_CURRENT_USER\Software\Microsoft\Office\16.0\Access\Security\Trusted Locations\Location1] "Path"="\\\\DESKTOP-AOJOU45\\test2\\" "AllowSubfolders"=dword:00000001 "Description"="" اما اذا اردنا عن طريق ملف دفعي فيمكن كتابته هكذا @Echo Off cd %systemroot%\system32 call :IsAdmin Reg.exe add "HKCU\Software\Microsoft\Office\16.0\Access\Security\Trusted Locations\Location1" /v "Path" /t REG_SZ /d "\\DESKTOP-AOJOU45\test2\\" /f Reg.exe add "HKCU\Software\Microsoft\Office\16.0\Access\Security\Trusted Locations\Location1" /v "AllowSubfolders" /t REG_DWORD /d "1" /f Reg.exe add "HKCU\Software\Microsoft\Office\16.0\Access\Security\Trusted Locations\Location1" /v "Description" /t REG_SZ /d "" /f Reg.exe add "HKCU\Software\Microsoft\Office\16.0\Access\Security\Trusted Locations\Location1" /v "Date" /t REG_SZ /d "09/01/2022 16:54" /f Exit Cls لم اقم بمراجعة الكود الخاص بالباتش كتبته بشكل سريع لا نشغالي والامر ليس ذو اهميه لكون تنفيذة من خلال الرجيسيتري اسهل دائما عندما نتحدث عن اي اكواد للرجيسيتري او ملفات الباتش فليس الهدف نسخ الكود وتنفيذه وانما اعطاء فكرة عن مثل هذه الملفات وما تستطيع فعله ويبقى على المتلقي ان يبحث ويعرف ان لها فائدة كبيرة وايضا اضرار قد تكون مضرة لنظام التشغيل لذا نشير اليها احيانا ولا نتوسع في الحديث تحياتي

وعليكم السلام-تفضل على الرغم انك لم تقم برفع ملف توضيحى لطلبك =LEN(A1)

بسيطة يمكنك استخدام هذه المعادلة فقط =SUMIFS($C$4:$C$17,$F$4:$F$17,"<>"&"مسدد",$B$4:$B$17,"<"&$H$2) 6.xlsx

أخي محمد عبدالله .. لتطبيق الدوال التي تفضل بها أخي محمد البرناوي .. أكتب هكذا : Dim i As Integer, k As Integer k = Me.NumberTxt ' تخزن القيمة الموجودة في مربع النص في المتغير For i = 1 To k << تضع هنا الأمر المراد تكراره >> Next i 🙂

دوال التكرار كثيرة ... انظر وطبق الأول: الدالة For Dim i As Integer, k As Integer k = 4 For i = k To 1 Step -1 MsgBox i Next i الثاني: الدالة Do While Dim i As Integer i = 4 Do While i >= 1 MsgBox i i = i - 1 Loop الثالث: الدالة Do Until Dim i As Integer i = 4 Do Until i < 1 MsgBox i i = i - 1 Loop الرابع: الدالة Do.....Loop Until Dim i As Integer i = 4 Do MsgBox i i = i - 1 Loop Until i < 1 الخامس: الدالة Do.....Loop While Dim i As Integer i = 4 Do MsgBox i i = i - 1 Loop While i >= 1

اليوم أقدم لكم موضوع يبحث عنة الكثيرين الموضوع هو كيفية إظهار بيانات محددة فى التقرير على هيئة QR CODE و هو الباركود الثنائى الابعاد 1 - مرفق مجلد مضغوط به ملفين DLL احدهم للويندوز 64 بت QRCodeFont_x64.dll و الاخر للويندوز 32 بت QRCodeFont.dll ما عليك الا وضع الملف المناسب للويندوز الخاص بك فى مجلد SYSTEM32 2 - و يوجد ايضا ملف MW6Matrix.TTF و هو يوضع فى مجلد C:\Windows\Fonts 3 - الكود التالى يتم لصقة فى محرر الفيجوال بيزك فى التقرير المراد إظهار الباركود به Option Compare Database Private Declare Sub QRCodeEncode Lib "QRCodeFont.dll" _ (ByVal Message As String, ByVal Version As Integer, ByVal Level As Integer, ByVal Mask As Integer) Private Declare Function QRCodeGetRows Lib "QRCodeFont.dll" () As Integer Private Declare Function QRCodeGetCols Lib "QRCodeFont.dll" () As Integer Private Declare Function QRCodeGetCharAt Lib "QRCodeFont.dll" (ByVal RowIndex As Integer, ByVal ColIndex As Integer) As Integer Private Const Version = 0 Private Const Level = 0 Private Const Mask = 0 ------------------------------------------------------------------ Private Sub Detail_Print(Cancel As Integer, PrintCount As Integer) Dim RowCount As Long Dim ColCount As Long Dim Message As String Dim EncodedMsg As String Message = Field1.Text Message = Message & vbCrLf & Field2.Text Message = Message & vbCrLf & "________" Message = Message & vbCrLf & " " Call QRCodeEncode(Message, Version, Level, Mask) RowCount = QRCodeGetRows() ColCount = QRCodeGetCols() EncodedMsg = vbCrLf For I = 1 To RowCount For J = 1 To ColCount EncodedMsg = EncodedMsg & Chr(QRCodeGetCharAt(I - 1, J - 1)) Next J EncodedMsg = EncodedMsg & vbCrLf Next I Text0.Value = EncodedMsg End Sub 4 - هذان السطران Message = Field1.Text Message = Message & vbCrLf & Field2.Text هما يعبران عن حقلى البيانات المراد إظهارهما فى الQR CODE الحقل Field1 و الحقل Field2 5 - و يمكنك إضافة المزيد من الحقول بإضافة السطر التالى Message = Message & vbCrLf & -----------.Text و يوضع اسم الحقل المراد إظهارة بدلا من ----------- 6 - فى السطر قبل الاخير فى الكود Text0.Value = EncodedMsg Text0هو اسم ال textbox الذى سيظهر به الكود و يمكنك تغييرة بالإسم الذى تريدة 7 - اخر شئ هو تغيير نوع الفونت (الخط) الخاص بال text box الذى سيظهر به الQR CODE إلى نوع الفونت MW6 Matrix و الذى وضعناه بمجلد الخطوط سابقا و شكرا لكم Desktop.rar