البحث في الموقع

السلام عليكم ورحمة الله وبركاتة برنامج استلام مواد محلية استلام محلى مباشرة يكون استلام مباشرة رقم التقرير الاستلام (RD089800117) RD رمز استلام مباشرة 08980 رقم التقرير 01 شهر 17 سنة رقم الطلبية (1004500 - 9110) 9110 مركز التكلفة - 1004500 يجمع مربع نص Order_No + مربع النص مركز التكلفة cost center رقم طلب التوريد Supply_No تاريخ الاستلام Received_date كود وصف الطلبية ID_descr كود المورد Resource code كود مندوب المشتريات MANDUB_No كود مستلم الطلبية من مواد MANcheckup_No مستلم الطلبية user ID استلام محلى مخزونية رقم التقرير الاستلام (RS089800117) RS رمز استلام مخزونية 08980 رقم التقرير 01 شهر 17 سنة رقم الطلبية (1004500 - 9110) 9110 مركز التكلفة - 1004500 يجمع مربع نص Order_No + مربع النص مركز التكلفة cost center رقم طلب التوريد Supply_No تاريخ الاستلام Received_date كود وصف الطلبية ID_descr كود المورد Resource code كود مندوب المشتريات MANDUB_No كود مستلم الطلبية من مواد MANcheckup_No مستلم الطلبية user ID استلام عشوائى استلام خارخى مباشرة استلام خارجى مخزونية ولكم منى جزيل الشكر Storeg.rar

المرجوا كود ترتيب معلومات الجدول /// code croissant ou decroissant مثلا من أحذت تاريخ أو من آخر معلومات أدخلت <?php $sql ="SELECT * FROM `match` "; $res = mysql_query($sql); while($don = mysql_fetch_array($res)){ ?> <td><div align="center">#<?php echo $don[0];?></div></td> <td><div align="center"><?php echo $don[1]?></div></td> <td><div align="center"><?php echo $don[3]?></div></td> <td><div align="center"><?php echo $don[2]?></div></td> <td><div align="center"><?php echo $don[4]?></div></td> </tr> <?php } ?>

السلام عليكم ورحمة الله وبركاته تحية طيبة لأخوانى الأعزاء بالمنتدى وجزاكم الله خيرا على تعاونكم معنا - جعله الله في ميزان حسناتكم وبعد,,, عندى 3 ملفات منفصلة :- ملف بإسم مطابقة - ملف بإسم عملاء - ملف بإسم رصيد عملاء أحتاج الى المقارنة بين ملف عملاء و رصيد عملاء ( من حيث كميات المنتجات المباعة ) حيث يحتوى كل ملف منهم على عشرات الشركات . الدالة التى اعرفها للقيام بالمقارنة هى دالة VLOOKUP وحتى استطيع استخدام دالة VLOOKUP يجب الإستعانة بملف وسيط ( مطابقة ) يظهر به بيانات ملف ( عملاء ) و ملف ( رصيد عملاء ) حتى أستطيع المقارنة بينهم. المطلوب 1- فى ملف (المطابقة) فى الخلية ( a1 ) عند اختيار اسم الشركة من القائمة المنسدلة يتم ترحيل البيانات الموجودة فى ملف ( عملاء ) بالجدول الملون ( Code المنتج يناير فبراير مارس أبريل مايو يونيو يوليو أغسطس سبتمبر أكتوبر نوفمبر ديسمبر الإجمالى ) 2- فى ملف (المطابقة) فى الخلية ( R1 ) عند اختيار اسم الشركة من القائمة المنسدلة يتم ترحيل البيانات الموجودة فى ملف ( رصيد عملاء ) بالجدول الملون ( كود المنتج - المنتج - يناير فبراير مارس أبريل مايو يونيو يوليو أغسطس سبتمبر أكتوبر نوفمبر ديسمبر الإجمالى ) 3- ان أمكن ذلك فى حالة تحديث الأرقام فى أى من ملف ( عملاء ) و ( رصيد عملاء ) يتم تحديث البيانات تلقائيا فى ملف ( المطابقة ) أعتذر عن الإطالة وكل عام وانتم بصحة وسعادة يارب إستدعاء بيانات.rar

Try to read the code to add a fourth column in the output. The code is so simple to read

تفضل أخي @Bshar ، تم الإستعانة بنموذج مؤقت Temp ، لإدراج قيم الفلترة فيه ومن ثم انشاء تقرير مبني على هذا الجدول . وهذا الكود ليقوم بتنفيذ المهمة :- Private Sub Rep_Btn_Click() ApplyFilter DoCmd.SetWarnings False DoCmd.RunSQL "DELETE FROM Temp" DoCmd.SetWarnings True Dim rs As DAO.Recordset Set rs = Me.tape5.Form.RecordsetClone If IsNull(Foksh) Then DoCmd.CancelEvent Exit Sub Else rs.MoveFirst Do Until rs.EOF Dim selectedValues() As String selectedValues = Split(Me.Foksh, ",") Dim i As Integer For i = LBound(selectedValues) To UBound(selectedValues) If InStr(1, rs!color, Trim(selectedValues(i)), vbTextCompare) > 0 Then CurrentDb.Execute "INSERT INTO Temp (ID, namee, [code-work], [t-namber], type, lincec, color) " & _ "VALUES (" & rs!ID & ", '" & Forms![add-tab]![xxf] & "', " & rs![code-work] & ", '" & rs![t-namber] & "', " & _ "'" & rs![type] & "', '" & rs![lincec] & "', '" & rs![color] & "')" Exit For End If Next i rs.MoveNext Loop rs.Close Set rs = Nothing DoCmd.OpenReport "Table1", acViewPreview End If End Sub Foksh.accdb وأعتذر عن التأخير بسبب ظرف صحي .

Not so clear but try this code Sub Test() Dim a, letters, i As Long, ii As Long, k As Long a = Sheet1.Range("C1").CurrentRegion.Value Rem letters = Split("ا,أ,إ,آ", ",") letters = Split("ب", ",") ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)) For i = 2 To UBound(a, 1) If IsNumeric(Application.Match(Left(a(i, 2), 1), letters, 0)) Then k = k + 1 For ii = LBound(a, 2) To UBound(a, 2) b(k, ii) = a(i, ii) Next ii End If Next i If k > 0 Then With Sheet2 .Columns("C:E").ClearContents .Range("C1").Resize(, 3).Value = Sheet1.Range("C1").Resize(, 3).Value .Range("C2").Resize(k, UBound(b, 2)).Value = b End With End If End Sub

أريد اضافة شريط متحرك بعد تنفيذ أمر Me.Hello_World = "1 from 7" like run code 1 Me.Hello_World = "2 from 7" like run code 2 Me.Hello_World = "3 from 7" like run code 3 Me.Hello_World = "4 from 7" like run code 4 Me.Hello_World = "5 from 7" ' like run code 5 Me.Hello_World = "6 from 7" ' like run code 6 Me.Hello_World = "6 from 7" ' like run code 7 أى عند تنفيذ كو د 1 يتحرك الشريط المتحرك حتى يصل الى كود 7 100% و يغلق النموذج عند وضع الكود عند الفتح لا يظهر النموذج لذلك وضعته عند عداد الوقت وجزاك الله كل خير Update.mdb

أخي @Bshar جزاك الله خيراً على هذه الثقة 🥰 . اتمنى أن أكون قد وصلت الى حل مناسب ، انظر ماذا فعلت للوصول لطلبك :- 1. قمت بالتعديل على الاستعلام والذي هو مصدر سجلات للنموذج الفرعي ليصبح فقط لفلترة الاسم . بهذا الشكل SQL :- SELECT doc.name, tape.ID, tape.[code-work], tape.[t-namber], tape.type, tape.lincec, tape.color FROM doc INNER JOIN tape ON doc.ID = tape.[code-work] WHERE (((doc.name) Like "*" & [Forms]![add-tab]![xxf] & "*")); 2. انشأت مربع نص وأسميته Foksh 😁 ، وجعلت قيمته :- Me.Foksh = Foksh & "," & Me.xxc ' هو كومبوبوكس الألوان XXC حيث 3. انشأت دالة لتطبيق الفلترة :- Private Sub ApplyFilter() Dim filterCriteria As String Dim selectedValues() As String Dim i As Integer selectedValues = Split(Me.Foksh, ",") For i = LBound(selectedValues) To UBound(selectedValues) If selectedValues(i) <> "" Then filterCriteria = filterCriteria & "[tape].[color] = '" & Trim(selectedValues(i)) & "' OR " End If Next i If filterCriteria <> "" Then filterCriteria = Left(filterCriteria, Len(filterCriteria) - 4) End If Me.tape5.Form.Filter = filterCriteria Me.tape5.Form.FilterOn = True End Sub 4. في حدث بعد التحديث للكومبوبوكس XXC سيتم نقل القيم الى مربع النص Foksh والفصل بين القيم عند تغييرها بالفاصلة "," :- Me.Foksh = Foksh & "," & Me.xxc ApplyFilter Me.tape5.Requery وفي النهاية هذا هو الناتج tesst.accdb

Do it yourself Press Alt + F11 >> Insert Module >> Paste the code

Try this code Sub Test() Dim ws As Worksheet, fso As Object, sPath As String, lr As Long, iRow As Long Set ws = ActiveSheet Set fso = CreateObject("Scripting.FileSystemObject") lr = ws.Cells(Rows.Count, 1).End(xlUp).Row ws.Columns(1).Interior.Color = xlNone For iRow = 2 To lr sPath = ThisWorkbook.Path & "\" & ws.Cells(iRow, 1).Value If fso.FolderExists(sPath) Then ws.Cells(iRow, 1).Interior.Color = vbGreen End If Next iRow End Sub

Private Sub MajInventaire() Dim v As Integer With Worksheets("Inventaire") lgD = .Cells(Rows.Count, 1).End(xlUp).Row + 1 For v = 0 To ListBox1.ListCount - 1 With .Cells(lgD, 3) If flgAdd = 0 Then .Offset(, -2) = ListBox1.List(v, 1) 'Code article .Offset(, -1) = ListBox1.List(v, 4) 'Catégorie .Offset(, 2) = ListBox1.List(v, 5) 'Seuil d'alerte .Offset(, 3) = ListBox1.List(v, 6) 'Descriptif .Offset(, 4) = ListBox1.List(v, 7) 'Référence .Offset(, 5) = ListBox1.List(v, 8) 'Unité de mesure .Offset(, 6) = "Transfert" 'Observations .Offset(, 9) = ComboBox2 'Magasin QD = Val(.Value) + QT: .Value = QD 'Stock actuel Else .Offset(, 7) = .Offset(, 7) + ListBox1.List(v, 9) End If lgT = lgT + 1 End With .Protect Next v End With End Sub صباح الخير هل يمكنكم مساعدتى الكود الذى ادرجتة لايعمل معى الكمية لاتخصم من شيت Inventaire ما الأخطاء فى هذا الكود copy-of-copy-of-quantite-transferee-4.xlsm

هل يوجد ملف اكسل انشاء QR code عن طريق مجموعة اسماء

السلام عليكم, في سنة 2017 قمت بكتابة كلاس بسيط لحماية برنامجي ولضمان برنامجي لا يعمل في غير كومبيوترات في حاله بيعه. مميزات الكلاس: 1- قفل قاعدة البيانات على ( رقم الهارد , البروسيسور , المذربورد , الماك أدريس ) 2- (استحاله) فك النماذج والتقارير في حال عدم تجاوزك لنموذج ( تسجيل الدخول ) ببساطة ستقول يمكنني العثور على باسورد القاعدة داخل الجدول ( الطريقة المعتادة لدينا جميعا في انشاء نموذج تسجيل دخول ). قبل كل شي ليكن لدينا مثلا جدول اسمة ( tbl_Login ) و نموذج اسمه ( frm_Login ) الجدول لتخزين اسم المستخدم وكلمة المرور والنموذج لعمل تسجيل الدخول عند ذهابنا للجدول ( tbl_Login ) ، سوف نحصل على باسورد مشفر من الجدول لو كان الباسورد مثلا ( 313 ) فإنك ستحصل على ( 701D6068 ) 2- عندما نقوم بتسجيل الدخول في النموذج سيقوم البرنامج بأخذ كلمة السر المدخلة ويقوم بتشفيرها ثم يقوم بمطابقتها مع الباسورد الموجود في الجدول اذا كان الباسورد المُدخل يطابق الجدول سيكتب قيمة معينة runtime ويقوم بازالة جميع القيود من النماذج والتقارير. اولا: كلاس الحماية Option Compare Database '----------------------------------------------------- ' Protection Module Coded By Hassanein Hirz Aldeen (SEMO.Pa3x) ' Date 26/11/2017 ' All rights reserved. copyright © 2017 '----------------------------------------------------- Public SEMO As String Function SEMO_GET() SEMO = SEMO SEMO_GET = SEMO End Function Function PR() As Boolean PR = False 'False=Disabled , True=Enabled End Function Function HWND_ID() HWND_ID = "3C3F4825" 'Your HWID End Function Function HWND_MSG() HWND_MSG = "...ليست لديك صلاحيات كافية لإستخدام هذا الاجراء" End Function Function KEY_ENDE() KEY_ENDE = "PA$X" End Function Function HWND_GET() Set root = GetObject("winmgmts:{impersonationlevel=impersonate}!\\.\root\cimv2") Set disks = root.execquery("select * from win32_logicaldisk") For Each disk In disks If disk.volumeserialnumber <> "" Then HWND_GET = disk.volumeserialnumber Exit For End If Next End Function Function HWND_PROTECTION() Set root = GetObject("winmgmts:{impersonationlevel=impersonate}!\\.\root\cimv2") Set disks = root.execquery("select * from win32_logicaldisk") For Each disk In disks If disk.volumeserialnumber <> "" Then HWND_PROTECTION = disk.volumeserialnumber Exit For End If Next If HWND_ID = HWND_PROTECTION Then HWND_PROTECTION = "True" Else HWND_PROTECTION = "False" End If End Function 'Code contained within module named mdlforencryptionanddecryption Public Function XORDecryption(CodeKey As String, DataIn As String) As String Dim arkdata1 As Long Dim strDataOut As String Dim intXOrValue1 As Integer Dim intXOrValue2 As Integer For arkdata1 = 1 To (Len(DataIn) / 2) 'The first value to be XOr-ed comes from the data to be encrypted intXOrValue1 = Val("&H" & (Mid(DataIn, (2 * arkdata1) - 1, 2))) 'The second value comes from the code key intXOrValue2 = Asc(Mid(CodeKey, ((arkdata1 Mod Len(CodeKey)) + 1), 1)) strDataOut = strDataOut + Chr(intXOrValue1 Xor intXOrValue2) Next arkdata1 XORDecryption = strDataOut End Function Public Function XOREncryption(CodeKey As String, DataIn As String) As String Dim arkdata1 As Long Dim strDataOut As String Dim temp As Integer Dim tempstring As String Dim intXOrValue1 As Integer Dim intXOrValue2 As Integer For arkdata1 = 1 To Len(DataIn) 'The first value to be XOr-ed comes from the data to be encrypted intXOrValue1 = Asc(Mid$(DataIn, arkdata1, 1)) 'The second value comes from the code key intXOrValue2 = Asc(Mid$(CodeKey, ((arkdata1 Mod Len(CodeKey)) + 1), 1)) temp = (intXOrValue1 Xor intXOrValue2) tempstring = Hex(temp) If Len(tempstring) = 1 Then tempstring = "0" & tempstring strDataOut = strDataOut + tempstring Next arkdata1 XOREncryption = strDataOut End Function الاستخدام لكل النماذج والتقارير اكتب في حدث Form_Load Option Compare Database Private Sub Form_Load() On Error Resume Next If HWND_PROTECTION = "False" Then MsgBox HWND_MSG, vbCritical, "عملية خاطئة" For i = 0 To Controls.Count - 1 Dim X As Control Set X = Me.Controls.Item(i) X.Visible = False Next DoCmd.Close DoCmd.CloseDatabase DoCmd.Quit End If If Protection.SEMO_GET = "SEMO" = False Then MsgBox HWND_MSG, vbCritical, "عملية خاطئة" For i = 0 To Controls.Count - 1 Dim XS As Control Set XS = Me.Controls.Item(i) XS.Visible = False Next DoCmd.Close DoCmd.CloseDatabase DoCmd.Quit End If End Sub الان عندما تريد اعطاء القاعدة لشخص ما قم باعطاءه اولا ملف الـ VBS هذا '----------------------------------------------------- ' ReCoded By Hassanein Hirz Aldeen (SEMO.Pa3x) ' Date 26/11/2017 ' All rights reserved. copyright © 2017 '----------------------------------------------------- ' Get clipboard text Set objHTML = CreateObject("htmlfile") Set Ws = CreateObject("WScript.Shell") Clipboardtext = objHTML.ParentWindow.ClipboardData.GetData("text") sText = HWND_GET 'Set Clipboard Ws.Run "mshta.exe ""javascript:clipboardData.setData('text','" & Replace(Replace(sText, "\", "\\"), "'", "\'") & "');close();""", 0, True MsgBox "Copied!" Function HWND_GET() Set root = GetObject("winmgmts:{impersonationlevel=impersonate}!\\.\root\cimv2") Set disks = root.execquery("select * from win32_logicaldisk") For Each disk In disks If disk.volumeserialnumber <> "" Then HWND_GET = disk.volumeserialnumber Exit For End If Next End Function وظيفة هذا الملف يقوم باستخراج ( رقم الهارد , البروسيسور , المذربورد , الماك أدريس ) ثم ينسخه بعدما يشغله سيقوم العميل باعطاءك هذا الرقم لكي تقوم انت بدورك بوضعه داخل الكلاس في المنطقة Function HWND_ID() HWND_ID = "Your HWID" End Function استبدل كلمة ( Your HWID ) بالرقم الذي سيعطيه لك العميل. ثم بعد ذلك قم بحفظ القاعدة بصيغة ( ACCDE ) واتحدا اي شخص يفتحها مرة اخرى: لكي تفتح النماذج والتقارير عليك بتخطي نموذج تسجيل الدخول ارفقت لكم قاعدة محمية وقاعدة بدون حماية مع ملف الـ VBS الذي يستخرج ارقام قطع الجهاز ويقوم بنسخها،، اتمنى لكم الفائدة جميعاً اهداء الموضوع الى مُعلمي الرائع @jjafferr حسنين Login_SEMO_Pa3x.rar

السلام عليكم الكود التالى وظيفة عمله تحديد الخلايا التي تحتوي على الاسماء ومن ثم سيتم عمل شيتات بنفس الأسماء الموجودة فى النطاق الذى تم تحيده Sub addsheet() Dim x As Object For Each x In Selection Worksheets.Add().Name = x Next x End Sub فـ كنت محتاج أدمج الكود التالى به Sub Copier() Dim s As String Dim numtimes As Integer Dim numCopies As Integer numCopies = InputBox("How many copies do you need?") s = InputBox("Enter the name of the Worksheet you want to copy") For numtimes = 1 To numCopies ActiveWorkbook.Sheets(s).Copy After:=ActiveWorkbook.Sheets(Worksheets.Count) Next End Sub الكود ده بيجى رسالة تكتب رقم لـ عدد النسخ المراد نسخها وبعدها بوكس تانى لإسم الشيت المراد نسخه فـ بالتالى محتاج أدمج الكود ده عشان أحدد أسماء الشيتات الـ هتتنسخ من خلال النطاق الذى يتم تحديده فـ النتيجة إن شاء الله هتكون بالضغط على الزر أولاً.. بوكس بتحديد عدد النسخ ثانياً.. بوكس بيطلب مننا نكتب اسم الشيت المراد نسخه ثالثاً.. بوكس بتحديد النطاق الـ هيكون فيه أسماء الشيتات الجديدة الـ هيتعملها Create وفى ننفس الوقت النقطة ( أولاً ) سيتم إلغاؤها لأن النقطة ( ثالثاً ) ستغنى عنها لوجود نطاق يحدد عدد النسخ وشكراً جزيلاً مقدماً لتفهمكم وتعاونكم

عباقرة قسم الأكسيس الأفاضل السلام عليكم ورحمة الله وبركاته البرنامج المرفق مصمم على Office 2003 وبه تقرير يسمى ( اثبات قيد ) مصدره استعلام يسمى ( Reports ) التقرير به جزء مخصص لإظهار QR Code لكل طالب ومصدره حقل ( Barcod ) الموجود باستعلام ( Reports ) حاولت وبحثت كثيرا لادراج QR Code لكل طالب بالتقرير يقرأ اللغة العربية ويظهر بيانات حقل ( Barcod ) عند قراءة الحقل بالموبايل أو قارئ الباركود ولم استطع الوصول لصيغة QR Code يقرا اللغة العربية ويكون مفعل بشكل دائم وليس تجريبى او لفترة معينة المطلوب المساعدة فى إنشاء QR Code فى نفس مكان الـ QR Code يقرأ اللغة العربية ويقبل اضافة حقول أخرى لحقل ( Barcod ) ويكون مفعل بشكل دائم وليس تجريبى او لفترة معينة عن طريق وحدة نمطية او ما شابه مع إمكانية تطبيق نفس الفكرة على تقارير أخري بنفس البرنامج مع خالص تحياتى لحضراتكم جميعا QR Code.mdb

اعادة المدة التجريبية لبرنامج التحميل RESET TRIAL INTERNET DOWNLOAD MANAGER - IDM - COPY THE CODE AND SAVE IT TEXT FILE WITH .BAT EXTENSION COD: Reg Delete "HKEY_CURRENT_USER\SOFTWARE\DownloadManager" /f Reg Delete "HKEY_CURRENT_USER\SOFTWARE\Classes\WOW6432Node\CLSID" /f exit OR DOWNLOAD THE FILE https://www.mediafire.com/file/8uuimooqdksbskt/IDM_Reset.rar/file

Private Sub CommandButton1_Click() Dim n If CB_Pièce = "Code article" Then MsgBox "Veuillez choisir un Code article.", 64, "Article requis": CB_Pièce.SetFocus: Exit Sub End If If Val(TextBox81) = 0 Then MsgBox "Stock provenance vide => retrait impossible !": Exit Sub If ComboBox2 = "" Then MsgBox "Veuillez choisir un Magasin de destination.": Exit Sub Dim T$, Qté&, chn$, b As Byte: T = "Contrôle Quantité" chn = TextBox82: If chn = "" Then MsgBox "Veuillez saisir une Quantité.", 64, T: Quantitetr.SetFocus: Exit Sub chn = Replace$(chn, ",", "."): If InStr(chn, ".") > 0 Then b = 1 'ni « , » ni « . » car Qté : nombre entier ! Qté = Val(chn): If Qté = 0 Then b = 1 'si chn est du texte ou 0, alors Qté = 0 => refusé ! If b = 1 Then MsgBox "Veuillez entrer une quantité valide !", 64, T Quantitetr = "": Quantitetr.SetFocus: Exit Sub End If If Qté > Val(stocktr.Caption) Then MsgBox "Quantité supérieure au stock actuel !", 64, T Quantitetr = "": Quantitetr.SetFocus: Exit Sub End If If Val(seuil.Caption) > Val(stocktr.Caption) Then MsgBox "Impossible d'effectuer ce transfert !", 64, T Quantitetr = "": Quantitetr.SetFocus: Exit Sub End If 'si y'a pas eu d'écriture sur "Inventaire", on quitte cette sub SANS Call MajInventaire: If lgD = 0 Then Exit Sub 'appeler LigneTransfert Call LigneTransfert: If lgT = 0 Then UndoOpInv 'ci-dessus : si y'a pas eu d'écriture sur "Transfert", faut ANNULER 'l'opération qui a été faite sur "Inventaire", car une opération de 'transfert n'est PAS valable si on n'a pas pu l'écrire sur une des 'deux feuilles "Inventaire" ou "Transfert". Unload Me End Sub Private Sub MajInventaire() Dim QS&, n&, v With Worksheets("Inventaire") flgAdd = 0 n = UBound(TblInv): lgS = 0: lgD = 0 GetLig ComboBox1, n, lgS: If lgS = 0 Then Exit Sub GetLig ComboBox2, n, lgD: If lgD > 0 Then flgAdd = 1 If lgD = 0 Then flgAdd = 0: lgD = n + 3 If lgD = 65000 Then MsgBox "Le tableau en feuille Inventaire est plein !", 48 lgD = 0: Exit Sub 'on fait rien, et on sort de la sub ! End If End If Application.ScreenUpdating = 0: .Unprotect: QT = Val(Quantitetr) With .Cells(lgS, 11) ' était (lgS, 3) QS = .Value + QT: .Value = QS: stocktr = QS End With Application.EnableEvents = False .Activate ' active la feuille If flgAdd = 0 Then ' insère une ligne .Rows("4:4").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove .Unprotect .Rows("5:5").Copy ' copie la ligne en dessous .Rows("4:4").PasteSpecial xlPasteFormats ' colle le format .Range("D5").Copy ' copie la cellule .Range("D4").Select ' sélectionne la cellule ActiveSheet.Paste ' colle (formule incluse) Application.EnableEvents = True lgD = 4 End If For v = 0 To ListBox1.ListCount - 1 With .Cells(lgD, 3) If flgAdd = 0 Then .Offset(, -2) = ListBox1.List(v, 3) 'Code article .Offset(, -1) = ListBox1.List(v, 4) 'Catégorie .Offset(, 2) = ListBox1.List(v, 5) 'Seuil d'alerte .Offset(, 3) = ListBox1.List(v, 6) 'Descriptif .Offset(, 4) = ListBox1.List(v, 7) 'Référence .Offset(, 5) = ListBox1.List(v, 8) 'Unité de mesure .Offset(, 6) = "Transfert" 'Observations .Offset(, 9) = ComboBox2 'Magasin QD = Val(.Value) + QT: .Value = QD 'Stock actuel Else .Offset(, 7) = .Offset(, 7) + Quantitetr ' End If lgT = lgT + 1 End With .Protect: Application.ScreenUpdating = -1 Next End With End Sub Private Sub LigneTransfert() Dim v 'remplir une ligne sur le tableau de la feuille "Transfert", 'mais s'il n'y a plus de ligne libre, on ne fait rien ! With Worksheets("Transfert") 'Lastrow = Range("a" & Rows.Count).End(xlUp).Row + 1 lgT = .Cells(Rows.Count, 1).End(3).Row + 1 For v = 0 To ListBox1.ListCount - 1 If lgT = 650000 Then MsgBox "Le tableau en feuille Transfert est plein !", 48 lgT = 0: Exit Sub 'on fait rien, et on sort de la sub ! End If Dim Stock1&, Stock2& Application.ScreenUpdating = 0: .Unprotect '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Stock2 = Val(stocktr): Stock1 = Stock2 + QT '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' With .Cells(lgT, 1) .Value = CB_Pièce 'Code article .Offset(, 1) = ListBox1.List(v, 2) 'Catégorie .Offset(, 2) = ListBox1.List(v, 3) 'Désignation .Offset(, 3) = ListBox1.List(v, 4) 'Référence ' .Offset(, 4) = ListBox1.List(v, 4) 'Stock actuel .Offset(, 5) = ListBox1.List(v, 6) 'Unité .Offset(, 6) = Date 'Date .Offset(, 7) = ComboBox1 'Provenance .Offset(, 8) = ComboBox2 'Destination .Offset(, 9) = QT '= ListBox1.List(v, 13) 'Quantité transférée '.Offset(, 10) = Stock2 'STOCK PR ' .Offset(, 11) = QD 'STOCK DES .Offset(, 12) = TextBox1 .Offset(, 13) = Format(Now, "mm/dd/yyyy hh:mm am/pm") lgT = lgT + 1 End With .Protect: Application.ScreenUpdating = -1 Next End With End Sub يوجد يوزرفورم Transfer1 نظرا لكثرة الاصناف اضفت listbox1 الى الفورم وعند ترحيل البيانات الى الليست بوكس يعمل بنجاح ولاكن عند ترحيلها الى ورقة العمل لايقوم بالحفظ يوجد خطاء ولا اعرف السبب تحويلات بين المخازن2.xlsm

السلام عليكم ورحمة الله وبركاته أولا: لا اعرف كيفية ادراج ماكرو في المنتدي ، لذلك اضطررت ان أكتبه كتابة هنا واشكر من يدلني على الطريقة ثانيا: اريد ان اتعرف على عامل التصفية المعين حاليا على ورقة العمل برمجيا حتى أتمكن من ارجاعه كما كان بعد ان انتهي من تشغيل ماكرو معين PreviousAutoFilterMode = Worksheets("Sheet1").AutoFilterMode rem the result of above line of code will be stored in the variable PreviousAutoFilterMode , the resulting value will be either True or False ActiveSheet.AutoFilterMode = False ' turning off AutoFilterMode some code some code some code ActiveSheet.AutoFilterMode = PreviousAutoFilterMode rem the above line of code will return Auto Filter Mode to the previous status either True or False rem and In turn, if it was True, then the filter will be set to the first row, A:A rem What I need is to set the filter to what it was filtered before turning AutoFilterMode off rem I mean , was the previous filter set to row 1 or row 5 or to a specific range of cells , how can I determine that Appreciate those who can help

code supprime svp

code supprime svp

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته اليوم جئتكم بفكرة جديدة وإبداعية لتحديث نسخة الواجهات FE لدى المستخدمين بدون الاستعانة بملفات وبرامج خارجية 🙂 وذلك بالاستعانة بملفي الواجهات FE وملف قاعدة البيانات ( الجداول ) BE فقط 😊 وقد قمت بشرح الفكرة ومحاولة تبسيطها قدر الإمكان من خلال الشرح الآتي مستعيناً بالله وتوفيقه .. :: أصل المشكلة :: أولاً : من المعلوم أنه يفضل أن يكون البرنامج مقسم إلى ملفين ( الواجهات FE - وقاعدة الجداول BE ) وذلك لكي يعمل عليه أكثر من مستخدم. FE: هي اختصار لـ Front End النهاية الأمامية .. أي ملف الواجهات و BE: هي اختصار لـ Back End النهاية الخلفية .. وهو ملف الجداول ملف الـ BE غالبا ما يكون مخزن في السيرفر بطريقة يمكن لجميع المستخدمين من الوصول إليه حيث أن البيانات جميعها يتم تخزينها فيه. ويتم توزيع ملفات الـ( FE) على أجهزة المستخدمين ، وهي محور حديثنا لهذا اليوم الرائع الجميل .. 😊 مختصر الكلام : أنه كثيرا ما يعاني مصممو البرامج من إعادة توزيع ملفات الواجهات ( FE ) على أجهزة المستخدمين عندما تكون هناك تحديثات جديدة على البرنامج أو معالجة لأخطاء في البرنامج ... الطريقة والفكرة التي سنتحدث عنها اليوم تقوم بحل هذه المعاناة وجعل البرنامج يقوم بتوزيع الـ (FE) نيابة عنك أوتوماتيكيا وبدون أي جهد يطلب من المستخدمين .. 😉 :: شرح الفكرة وآلية العمل :: الفكرة التي سأطرحها قائمة على الاتصال بملف الجداول الـ (BE) والاستعانة به ليقوم بتوزيع ملف التحديث الجديد على أجهزة المستخدمين بعد أن يستبدل القديم بالجديد .. حيث أننا سنحتاج إلى : 1 - جدول في قاعدة الـ (BE) ومتصل بنسخة الـ (FE) كذلك، لتخزين روابط مواقع كل ملف ( FE - BE - New Update ). 2- ماكرو Autoexec وضيفته تشغيل الكود الذي سيفحص وجود تحديثات جديدة من عدمه عند بدء تشغيل البرنامج ، ويوضع في نسخة الـ (FE). 3- سنحتاج لإضافة نموذج في نسخة الجداول الـ (BE) مهمته تشغيل الكود الذي سيحدث نسخة الـ (FE). والكود يعمل عند حدث (عند التشغيل - ON OPEN ). 4- سنحتاج لجدول (محلي) يبقى في نسخة الواجهات الـ (FE) فيه حقل تاريخ عبارة عن سجل واحد يكتب فيه تاريخ الإصدار للنسخة الحالية. وهذا شرح مصور مبسط لآلية العمل : الصورة (1) : محتويات الملفات الأساسية المستخدمة في العمل. الصورة (2) : المرحلة الأولى : فحص وجوود تحديثات جديدة من خلال ملف الواجهات FE الصورة (3) : رسالة تأكيد للبدء في التحديث الصورة (4) : الخطوة الثالثة : إغلاق ال(FE) وفتح ال(BE) الصورة (5) : إستبدال النسخة القديمة بالجديدة وإعادة تشغيل البرنامج 🙂 هذا كل شيء ببساطة 😅🖐️ :: الأكواد المستخدمة :: أولاً : الكود المستخدم في ملف الواجهات الـ (FE) : Public Sub UpdateUsersFE(CurrentVerDate As Date, NewVerDate As Date, _ txtOldFEPath As String, txtNewFEPath As String, _ txtBEPath As String, txtBEUpdateForm As String, _ DoTheUpdaet As Boolean) On Error Resume Next ' ************************************************** Check If the Manager Send The Update Order If DoTheUpdaet = True Then ' Continue The Code Else MsgBox "لا يوجد تحديث جديد" Exit Sub End If ' ************************************************** Check Version Date If CurrentVerDate < NewVerDate Then ' Continue The Code ' MsgBox "سوف يتم التحديث إن شاء الله" ' Exit Sub Else ' MsgBox "لديك آخر إصدار" Exit Sub End If ' *************************************************** Confermation Msg. If MsgBox("لديك تحديث جديد للبرنامج، متابعة؟", vbYesNo, "Apply New Update?") = vbYes Then Else: Exit Sub End If ' ************************************************** Open the BE and the Update Form Dim objAdb As Object Set objAdb = CreateObject("Access.Application") objAdb.OpenCurrentDatabase (txtBEPath) objAdb.DoCmd.OpenForm txtBEUpdateForm objAdb.Visible = False ' ************************************************** Close FE Database DoCmd.Quit Set objAdb = Nothing End Sub Public Function testUpdate() Dim BackEndPath As String, FrontEndPath As String, UpdatePath As String, CurrentVerDate As Date, NewVerDate As Date, StartUpdating As Boolean CurrentVerDate = DFirst("[VersionDate]", "[FE_Tbl_Version]") NewVerDate = DFirst("[LastUpdateDate]", "[BE_Tbl_Updates]") BackEndPath = DFirst("[BackEndPath]", "[BE_Tbl_Updates]") FrontEndPath = DFirst("[FrontEndPath]", "[BE_Tbl_Updates]") UpdatePath = DFirst("[UpdatePath]", "[BE_Tbl_Updates]") StartUpdating = DFirst("[StartUpdating]", "[BE_Tbl_Updates]") Call UpdateUsersFE(CurrentVerDate, NewVerDate, FrontEndPath, UpdatePath, BackEndPath, "BE_Frm_StartUpdating", StartUpdating) End Function ثانياً : الكود المستخدم في ملف الجداول الـ (BE) : #If VBA7 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #Else Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If Private Sub Form_Open(Cancel As Integer) Call UpdateFE End Sub Public Sub UpdateFE() Dim FrontEndPath As String, NewUpdatePath As String FrontEndPath = DFirst("[FrontEndPath]", "[BE_Tbl_Updates]") NewUpdatePath = DFirst("[UpdatePath]", "[BE_Tbl_Updates]") 'On Error Resume Next '********************************************************************(Waite for 3 seconds until FE Closed ) Sleep 3000 '********************************************************************(Copy the New Update to the User PC) Dim fs As Object Set fs = CreateObject("Scripting.FileSystemObject") 'Kill FrontEndPath 'Sleep 1000 fs.CopyFile NewUpdatePath, FrontEndPath, True '********************************************************************(Open the new FE for the user) 'Sleep 1000 Dim objAdb As Object Set objAdb = CreateObject("Access.Application") objAdb.OpenCurrentDatabase (FrontEndPath) objAdb.Visible = True objAdb.DoCmd.RunCommand acCmdAppMaximize '*********************************************************************(Close BE) DoCmd.Quit Set objAdb = Nothing End Sub :: (مهم جدا ) قبل التجربة والتطبيق :: ستجدون في المرفقات ثلاثة ملفات: - ملف الواجهات القديم (FE-MyApplication) - ملف الجداول (BE-MyApplicationDatabase) -وملف الواجهات المحدث (FE-NewUpdateV2.0) أولاً : يجب إعادة ربط ملفي الواجهات (القديم + التحديث ) بملف الجداول (يدوياً ) .. وهي خطوة مهمة للعمل .. ( يمكنك عملها أوتوماتيكيا بالأكواد في برنامجك لاحقاً ، لم أشأ تعقيد الأمور هنا 😅) ثانياً : يجب عليك تحديث روابط أماكن الملفات الثلاثة في جدول (BE_Tbl_Updates) وذلك من خلال النموذج (FE_Frm_UpdateInfo) الموجود في نسخة الواجهات. والآن يمكنك الانطلاق والبدء في تجربة البرنامج 😉👊 قم بتشغيل البرنامج FE-MyApplication وانتظر لترى النتيجة 😊👌 ملاحظة : لإعادة التجربة مرة أخرى بعد التحديث ، قم بتأخير تاريخ النسخة الأمامية من جدول (FE_Tbl_Version) إلى تاريخ سابق للتاريخ المخزن في قاعدة البيانات . *************************************************************** هذا كل شيء ولا تنسوا أن تنوروني بآرائكم ومقترحاتكم ولا تنسوني من صالح دعواتكم 😊 :: التحميل :: FrontEnd Updator V1.0.rar

الحمد لله تم ايجاد الحل المناسب ،، كود يقوم بتقسيم وتوزيع القيم الموجودة في الـ QR والتي تفصل بينها فاصلة "," على مربعات النص بعد تحديدها . والكود التالي كان هو الحل :- Private Sub cmdQR_Click() Dim txtBoxA As TextBox Dim txtBoxB As TextBox Dim txtBoxC As TextBox Dim txtBoxD As TextBox Set txtBoxA = txtContent Set txtBoxB = txtContent1 Set txtBoxC = txtContent2 Set txtBoxD = txtContent3 Dim qrText As String qrText = Nz(ReadQRCode.Value, "") Dim qrValues() As String qrValues = Split(qrText, ",") If UBound(qrValues) >= 3 Then txtBoxA.Value = qrValues(0) txtBoxB.Value = qrValues(1) txtBoxC.Value = qrValues(2) txtBoxD.Value = qrValues(3) 'هنا نستطيع إضافة أي إجراء Else MsgBox "Error QR code !" End If End Sub

^_^ سبقتني لكن احب ان اضيف مشاركه مع اخي @Foksh تفضل هل هذا ما تريد 1234.rar ولتعم الفائدة وتضويح ما تم تم استخدام هذا الكود Sub GetInfo1() Dim db As DAO.Database Dim rst As DAO.Recordset Set db = CurrentDb Set rst = db.OpenRecordset("Sale_Reg", dbOpenDynaset) With rst .AddNew ![Sale_code] = DLookup("code", "main_itemn", "code=" & "Sale_code") ![Sale_Number] = 1 ![Sale_invoice] = Forms![Sale]![Invoice_Number] ![SSale_Price] = DLookup("Slae_price", "main_itemn", "code=" & "Sale_code") ![Sale_Date] = DLookup("Reg_Date", "main_itemn", "code=" & "Sale_code") ![Sale_Item_Name] = DLookup("item", "main_itemn", "code=" & "Sale_code") ![frosh_date] = Date ![scompany_name] = DLookup("company_name", "qry1", "code=" & "Sale_code") .Update .Close End With Set rst = Nothing db.Close Set db = Nothing End Sub مع ان هناك حلول اخري لكن وجدت الاسهل والاسرع للحلول دون تغير (او فرض راي) على المبرمج

عندي قاعدة بيانات بها عدة جداول مربوطة ببعض عن طريق علاقات كثيرة أريد تصفير حقل التسلسل التلقائي في كل قاعدة البيانات بضغطة زر بحيث تبدأ جميع الجداول من رقم 1 وكذلك عند حذف صف من الجدول يبدأ من بعده الترقيم التلقائي وشكرا جزيلا مقدما

استاذى الفاضل اعتذر عن عدم توضيح الفكره لكن مرفق فكره عمل الشيت =MAX(0,MIN(VLOOKUP(E2,'code-ST24'!A$2:E$108940,5,0)-SUMIF(E$1:E1,E2,G$1:G1),G2)) الصيغه تعمل ( باسقاط الرصيد بالشيت حسب الكميه المباعه بالعقد code-ST24 وتعمل بشكل صحيح ✔✔ الكميه بالتوريد =IF(G2>K2,MAX(MIN(SUMIF('factory-mp-2024'!A$5:A$14707,E2,'factory-mp-2024'!B$5:B$14707)-SUMIF(E$1:E1,E2,L$1:L1),G2-K2),0),0 الصيغه تعمل ( باسقاط الكميه بالتوريد بالشيت حسب الكميه المباعه بالعقد factory-mp-2024 وتعمل بشكل صحيح ✔✔ =IF(G2=K2,"01-01-2000",IF(K2+L2<G2,"01-01-2030",SUMPRODUCT(SMALL(UNIQUE(('factory-mp-2024'!A$5:A$10307=E2)*('factory-mp-2024'!C$5:C$10307>=SUMIF(E$2:E2,E2,L$2:L2))*'factory-mp-2024'!D$5:D$10307),2)))) هدف الصيغه مقارنه الكميات بالرصيد والعقد وتعطى 01-01-2000 ان كانت الكميه متساويه بعد ذلك تنظر بشيت factory-mp-2024 وتسجل تاريخ التوريد للقطعه حسب تسلسل التوريد والكميات والتاريخ تعطى 01-01-2030 ان كانت الكميات بالرصيد +التوريد اقل من المباع وتعمل بشكل صحيح ✔✔ بالدرايف المطلوب نفس الفكره بالاكسيل شيت بسبب عدم وجود UNIQUE 2013+2019