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

أذا كان المطلوب مسح ( إفراغ ) البيانات الموجودة في حقول الجدول استخدم هذا الكود وضعه تحت حدث عند نقر الزر DoCmd.RunSQL "UPDATE tbl_Q SET tbl_Q.q_Ch1 = "" "" ,q_Ch2 = "" "",q_Ch3 = "" "",q_Ch4 = "" "",q_Ch5 = "" "";" ' tbl_Q هو اسم الجدول 'q_Ch1 هو اسم الحقل الاول 'q_Ch2 هو اسم الحقل الثاني 'q_Ch3 هو اسم الحقل الثالث 'q_Ch4 هو اسم الحقل الرابع 'q_Ch5 هو اسم الحقل الخامي أما إذا كانت المقصود هو مس ( إفراغ ) بيانات مربعات النص في النموذج استخدم هذا Me.txt1 = "" Me.txt2 = "" Me.txt3 = "" Me.txt4 = "" Me.txt5 = "" ' txt1 هو اسم مربع النص الموجود في النموذج

بارك الله فيك أستاذ وجيه الكود ممتاز ويعمل بكفاءة جعله الله في ميزان حسناتك

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

جرب هذا =IIf([Forms]![lsh]![combo1]="M",[Qavilable]-[Q],[Q]-[Qavilable])*[Y]

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

وعليكم السلام -كان لزاما عليك من البداية رفع ملف وشرح عليه المطلوب بكل دقة تجنبا لعدم اهدار الوقت فخطوات عمل التقييد ومنع ادخال المكرر في عمود كالتالى : نقوم باختيار من قائمة Data data Validation ثم Setting وبعد ذلك Custom وبعد ذلك تقوم بلصق هذه المعادلة في المكان المخصص لذلك في Formula وذلك للتقيد في العمود الأول A Formula =COUNTIF($A$1:A1,A1)=1 وهذا هو ملف العمل تقييد المدخلات.xlsx

تفضل لك كل ما طلبت-نورتنا في المنتدى وضع علامة عشرية بعد رقمين وترحيل بيانات الموظف الى الإستمارة.xlsx

وعليكم السلام-تفضل لك ما طلبت-نورتنا في المنتدى 1فاتورة.xlsm

وعليكم السلام تفضل ProgControlCard.mdb

العفو أخي هذا لعدم عرض #خطأ في حال قيمة مربع DT تكون خالية

تفضل Projects.accdb

تفضل عدد العملاء معدل.xlsx

تفضل لإثراء الموضوع بعد اذن الأستاذ حسين المشتريات.xlsx

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

شكرا جزيلآ استاذي الكريم على اثرائي بهذه المعلومات مقدرا جهودك 🌹 تمت الإجابة

الملحوظة الأولي : تطبيق التلوين على المعادلات ايضا و ليس النصوص فقط ربما لا يمكن عمل ذلك ، و اتمني أن يجد الأخوة حل لهذا الأمر الملحوظة الثانية : تطبيق التلوين على ما يكتب من النصوص و ليس فقط عند تعديل الخلية C1 جرب التعديل البسيط التالي لكود الأخ وجيه Private Sub Worksheet_Change(ByVal Target As Range) Dim lr As Integer If IsEmpty(Range("c1")) Then Exit Sub lr = Range("b" & Rows.Count).End(xlUp).Row Range("b4:b" & lr).Font.ColorIndex = xlAutomatic For Each c In Range("b4:b" & lr) For i = 1 To lr If Mid(c.Value, i, Len(Range("c1"))) = Range("c1").Value Then c.Characters(i, Len(Range("c1"))).Font.Color = vbRed End If Next Next End Sub

مثل العادة ابو عارف يبدع وسباق لكل خير نفس الكود بطريقة اخرى DoCmd.SetWarnings False Dim SQL As String SQL = "UPDATE العملية SET العملية.[سعر الشراء] = " & [سعر الشراء] & _ " WHERE (((العملية.[اسم المادة])='" & Me.الاسم & "'));" DoCmd.RunSQL SQL DoCmd.SetWarnings True

وياك وياك أخي

وعليكم السلام تفضل 2.rar

السلام عليكم أعتقد أن الخلل يكمن في "الارتباطات الخارجية" بملف آخر (مغلق)... ارفق الملف المعني بالخلل حتى نتبين أكثر... تحياتي الخالصة

بسم الله الرحمن الرحيم برنامج صغير سهل الأستخدام للمنشآت الصغيرة سهل وحجم البرنامج صغير ،أكسس 2003 الرقم السري 1975 ، أي ملاحظات نرجو الأفادة item.mdb

السلام عليكم يمكن هذا حل آخر للمسألة... بن علية حاجي دوام.xlsx

ربما ينال الاعجاب هذا الملف Fuction_split_name.xlsm

معلومه جميله من مبدع مثلك

افترض ان هذا المطلوب (صفحة salim من هذا الملف) Dawam_new_1.xlsx

تفضل اخي الفاضل On Error Resume Next ''''''''''''''''''''''' Me.txt1 = DLookup("[BARCODEحقل]", "TABOL1 جدول", "[BARCODEحقل]='" & Me.SERH حقل البحث & "'") '''''''''''''''''' If Len(Me.TXT1 & "") = 0 Then MsgBox "هذا الباركود غير مسجل" Undo Exit Sub End If انشأ مربع نص غير منضم وسميه TXT1 ضع هذا الكود حذث بعد التحديث في مربع النص الذي تسميه الصندوك الذي تبحث فيه وهتسميه SERH

ضع هذا الكود Private Sub chek_Click() If op = True Then Me.op = False Else Me.op = True End If End Sub

السلام عليكم الاخ الكريم وضعت فورم وفيه تيكسبوكس للبحث وليست بوكس لاظهار النتائج وزر للاستعلام اتمنى ان ما تبحث عنه تحياتي المرحليات.xlsm

مشاركة مع اخي كنري ضع هذا الكود في مدويل او براس النموذج Function AddRefs() Dim loRef As Access.Reference Dim intCount As Integer Dim intX As Integer Dim blnBroke As Boolean Dim strPath As String On Error Resume Next 'Loop through each reference in the database 'Add all references Debug.Print "----------------- Add References -----------------------" With Access.References .AddFromFile "C:\Windows\System32\DBPix20.ocx" .AddFromFile "C:\Windows\SysWOW64\DBPix20.ocx" End With ' Call a hidden SysCmd to automatically compile/save all modules. Call SysCmd(504, 16483) End Function ثم استدعيه عند فتح النموذج او في زر امر كما تشاء Call AddRefs

تفضل هذا المثال اخي الكريم تصدير و استيراد.accdb

هذا الملف عملته في بداية تسجيلي في الموقع 😎 تحياتي لك ايها الشاعر الاديب 😀

جرب الملف زر طباعة الكل اي تعديلات انا جاهز ان شاء الله تحياتي التصفية حسب اسم المركز.xlsm

وعليكم السلام -جرب هذا أستاذ محمد بمعادلات المصفوفة Quiry-لمساعدة فى كود استعلام بناء على اكثر من شرط.xlsx

بارك الله فيك وزادك الله من فضله

المعادلة تعمل بكل كفاءة وتم تجربتها

تفضل اخى الكريم كان عليك استخدام خاصية البحث فى المنتدى قبل رفع المشاركة https://www.officena.net/ib/topic/39234-طريقة-تحويل-ملف-اكسل-الى-csv-أو-vcf/\ او يمكنك من هنا ايضا https://convertio.co/ar/xls-csv/

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

تفضل كان عليك رفع ملف بالمطلوب من البداية Test.xlsx

تفضل هذا الكود اذا قمت بالكتابة فى العمود الأول A والعمود الثالث C سيعمل هذا الكود على تلوين المتشابه الغير متماثل باللون الأصفر Sub compare_cols122() Dim NameList As Worksheet Dim i As Long, j As Long Set NameList = Excel.Worksheets("Names") Dim rngNames As Range Set rngNames = Range("A1", Range("A1").Offset(Rows.Count - 1).End(xlUp)) Dim varNames As Variant varNames = rngNames.Value2 Dim rngData As Range Set rngData = Range("C1", Range("C1").Offset(Rows.Count - 1).End(xlUp)) Dim varData As Variant varData = rngData.Value2 Application.ScreenUpdating = False For i = LBound(varNames) + 1 To UBound(varNames) For j = LBound(varData) + 1 To UBound(varData) If varNames(i, 1) <> "" Then If InStr(1, varData(j, 1), varNames(i, 1), vbTextCompare) > 0 Then NameList.Cells(j, 3).Interior.ColorIndex = 6 NameList.Cells(i, 1).Interior.ColorIndex = 6 Exit For Else End If End If Next j Next i Application.ScreenUpdating = True End Sub

يمكنك اخذ نفس هذه المعادلة والتعديل عليها كما تشاء .

الأمر بسيط جدا اولا عليك بفتح مديول جديد ووضع هذا الكود به كما هو بالملف المرسل لك سابقا Option Explicit 'Main Function Function SpellNumber(ByVal MyNumber) Dim Euro, Cent, Temp Dim DecimalPlace, Count ReDim Place(9) As String Place(2) = " Mille " Place(3) = " Million " Place(4) = " Milliard " Place(5) = " Billion " ' String representation of amount. MyNumber = Trim(Str(MyNumber)) ' Position of decimal place 0 if none. DecimalPlace = InStr(MyNumber, ".") ' Convert Fils and set MyNumber to Dinar amount. If DecimalPlace > 0 Then Cent = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & _ "00", 2)) MyNumber = Trim(Left(MyNumber, DecimalPlace - 1)) End If Count = 1 Do While MyNumber <> "" Temp = GetHundreds(Right(MyNumber, 3)) If Temp <> "" Then Euro = Temp & Place(Count) & Euro If Len(MyNumber) > 3 Then MyNumber = Left(MyNumber, Len(MyNumber) - 3) Else MyNumber = "" End If Count = Count + 1 Loop Select Case Euro Case "" Euro = "No Euro" Case "Un" Euro = "Un Euro" Case Else Euro = Euro & "Euro" End Select Select Case Cent Case "" Cent = " et Non Cent" Case "Un" Cent = " et Un Cent" Case Else Cent = " et " & Cent & " Cent" End Select SpellNumber = Euro & Cent End Function ' Converts a number from 100-999 into text Function GetHundreds(ByVal MyNumber) Dim Result As String If Val(MyNumber) = 0 Then Exit Function MyNumber = Right("000" & MyNumber, 3) ' Convert the hundreds place. If Mid(MyNumber, 1, 1) <> "0" Then Result = GetDigit(Mid(MyNumber, 1, 1)) & " Cent " End If ' Convert the tens and ones place. If Mid(MyNumber, 2, 1) <> "0" Then Result = Result & GetTens(Mid(MyNumber, 2)) Else Result = Result & GetDigit(Mid(MyNumber, 3)) End If GetHundreds = Result End Function ' Converts a number from 10 to 99 into text. Function GetTens(TensText) Dim Result As String Result = "" ' Null out the temporary function value. If Val(Left(TensText, 1)) = 1 Then ' If value between 10-19... Select Case Val(TensText) Case 10: Result = "Dix" Case 11: Result = "Onze" Case 12: Result = "Douze" Case 13: Result = "Treize" Case 14: Result = "Quatorze" Case 15: Result = "Quinze" Case 16: Result = "Seize" Case 17: Result = "Dix-sept" Case 18: Result = "Dix-huit" Case 19: Result = "Dix-neuf" Case Else End Select Else ' If value between 20-99... Select Case Val(Left(TensText, 1)) Case 2: Result = "Vingt " Case 3: Result = "Trente " Case 4: Result = "Quarante " Case 5: Result = "Cinquante " Case 6: Result = "Soixante " Case 7: Result = "Soixante-dix " Case 8: Result = "Quatre-vingts " Case 9: Result = "Quatre vingt dix " Case Else End Select Result = Result & GetDigit _ (Right(TensText, 1)) ' Retrieve ones place. End If GetTens = Result End Function ' Converts a number from 1 to 9 into text. Function GetDigit(Digit) Select Case Val(Digit) Case 1: GetDigit = "Un" Case 2: GetDigit = "deux" Case 3: GetDigit = "Trois" Case 4: GetDigit = "Quatre" Case 5: GetDigit = "Cinq" Case 6: GetDigit = "Six" Case 7: GetDigit = "Sept" Case 8: GetDigit = "Huit" Case 9: GetDigit = "Neuf" Case Else: GetDigit = "" End Select End Function ثم بعد ذلك فى شيت الإكسيل ,مثلا اذا كان الرقم المراد تحويله الى حروف باللغة الفرنسية موجود بالخلية A2 -فعليك كتابة هذه المعادلة فى المكان الذى تريد اظهار الحروف به ="Seulement"&SpellNumber(A2) بارك الله فيك اتمنى ان تكون الصورة واضحة لك الأن

اهلا بك اخى الكريم فى المنتدى تفضل جمع وقسمة.xlsx

تفضل تفقيط فرنسى.xlsm

اخى الكريم المشكلة من عندك عليك بتفعيل وحدات الماكرو لديك لابد ان تكون وحدات الماكرو لديك مفعلة كما بالصورة

تفضل هذا كود لحفظ الملف بصيغة XLSM ويكون اسم الملف موجود بالخليتين M1 & M2 Sub SaveAs() ThisWorkbook.Save 'save current workbook in current name With Application.FileDialog(msoFileDialogSaveAs) .AllowMultiSelect = False .FilterIndex = 2 .InitialFileName = Range("M2").Text & Range("M1").Text 'specify folder - can also include default filename in here too If .Show Then ActiveWorkbook.SaveAs Filename:=.SelectedItems(1), _ FileFormat:=xlOpenXMLWorkbookMacroEnabled End If End With End Sub وهذا كود لحفظ الملف بصيغة PDF Sub PDFActiveSheet() Dim wsA As Worksheet Dim wbA As Workbook Dim strTime As String Dim strName As String Dim strPath As String Dim strFile As String Dim strPathFile As String Dim myFile As Variant On Error GoTo errHandler Set wbA = ActiveWorkbook Set wsA = ActiveSheet strTime = Format(Now(), "yyyymmdd\_hhmm") strPath = wbA.Path If strPath = "" Then strPath = Application.DefaultFilePath End If strPath = strPath & "\" strName = Replace(wsA.Name, " ", "") strName = Replace(strName, ".", "_") strFile = strName & "_" & strTime & ".pdf" strPathFile = strPath & strFile myFile = Application.GetSaveAsFilename _ (InitialFileName:=strPathFile, _ FileFilter:="PDF Files (*.pdf), *.pdf", _ Title:="Select Folder and FileName to save") If myFile <> "False" Then wsA.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=myFile, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False MsgBox "PDF file has been created: " _ & vbCrLf _ & myFile End If exitHandler: Exit Sub errHandler: MsgBox "Could not create PDF file" Resume exitHandler End Sub

اجعل نوع الخط Wingdings 2

تفضل دفتر التنقيط.xlsm

كيف نقوم بمساعدتك على ملف محمى بكلمة سر

المسألة واضحة ليست بحاجة الى شرح تم الاعلان عن متغير mys اذا تم الفتح بطريقة نظامية المتغير سيحمل القيمة 5 عند فتح اي نموذج والقيمة لا تساوي 5 يتم اغلاق قاعدة البيانات مرفق مثال بدون الوحدة النمطية التي تحمل قيمة mys وانما نستخدم الوحدة النمطية لاستعمالات اوسع dbx2.rar

نعم في المثال ما يغني عن المقال dbx.rar