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

هنا موضوع مشابه وللفائدة https://www.officena.net/ib/topic/64142-تغيير-صيغة-الترقيم-التلقائي-ليبدأ-بـ-mr000001-بدلا-من-1/#comment-416775 تحياتي

السلام عليكم قمت بتصميم برنامج اكسل لحساب عداد البنزين والمازوت في محطات الوقود / محاسبة مبيعات المحطة من تعبئة السيارات في كل وردية عمل / = الفكرة تعتمد على ارقام العدادت الموجودة في مضخات التعبئة حيث ان الرقم الموجود لا يتكرر ولا يرجع الى الخلف ولكن يعد بمجرد تعبئة السيارة بالوقود لنفرض ان العداد كان صباحا 15600 ومساءا 16200 هاذا يعني انا كمية المبيع اليومي هي 16200-15600=600 ليتر وسعر اللتر 1070 يصبح الرقم 600*1070=642000 هذا المبلغ الذي يجب ان اقبضه من العاملهذه الفكرة مبسطة وقمن انا بتجميعها بالاكسل بطريقة الفورم البرنامج مكتما بنسبة 90% باقي اضافة البونات واسعارها لتنخصم من المبيع ارجو من الجميع تجربتها واعطائي الملاحظات عن العمل او اذا كام هناك اخطا انا غفلت عنها وهل هناك طريقة لتطويره بشكل افضل والسلام عليكم لؤي AMS FORM.rar

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

السلام عليكم ورحمة الله اكتب هذا الكود فى حدث الورقة 2 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$H$15" Or Target.Address = "$H$17" Then For R = 4 To 9 If Target.Value = Sheet1.Cells(R, 3).Value Then Target.Interior.ColorIndex = Sheet1.Cells(R, 3).Interior.ColorIndex End If Next End If End Sub

ابشر .. وسنشارك الاستاذ ابا خليل بما يفتح الله علينا تحياتي

العفو منك ومن صاحب الموضوع يعلم الله ان الشرف لنا بالمساعدة وتبادل الافكار

يا صاحب الموضوع لك الشرف ان استاذنا الكبير رمهان رد عليك عسانا ننهل من علمه سلمت يداك أخى رمهان ونحب نشوفك أكتر بتشارك فى المنتدى :)

هذي اول طريقة تعلمتها في البحث Private Sub Text1_AfterUpdate() namebook.SetFocus DoCmd.FindRecord Text1, acAnywhere End Sub

نعم ممكن لكن ممكن ترفع الملف لكي نتم العملية عليه ؟ مع تقدير

من منا لايرغب بأن تكون الصفحة لديه مرتبة، وأن يعتمد أبعاد الخلايا كمرجع لتنظيم العمل ، إليكم ماكرو للتعرف على أبعاد الخلية النشطة.. cellsize.rar

برنامج بسيط يقوم بتحليل نتائج 3 فصول معا البرنامج باللغتين الانجليزية والعربية اختار ما تشاء 11LA -11LB -11S.rar

انتظر وصول الغداء ، فما عندي شغلة الآن ، فقلت ارد عليك اذا كنت تريد الرجوع عن آخر تعديل ، وما يهمك تعديلات امس لبكرة ، اعمل لك حقول تراجع غير مضمنه بعدد الحقول التي تريد التراجع عنها ، وفي الحدث "قبل التحديث" للحقل ، انسخ قيمته لحقل التراجع الخاص به. اما اذا كنت تريد اكثر من تراجع للحقل (مثل Undo الوورد والاكسل مثلا) ، ففي الحدث "قبل التحديث" للحقل ، انسخ قيمته في سجل جديد في حقل التراجع الخاص به في جدول التراجع جعفر

وعليكم السلام وبدون معلومات خاصة منك لطلبك ، تستطيع ان تتراجع عن القيمة التي قمت بها الى القيمة السابقة ، عن طريق me.Text1.oldvalue بشرط ان لا تكون قد حفظت السجل بعد جعفر

وعليكم السلام بالاضافة الى ما تفضل به اخي شفان ، اليك رابط فيه نفس الطلب: جعفر

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

اخي العزيز اذا تريد بيظهر حرف غ بدل قيمة سالب استخدم دالة IIF شوف الصور راح يظهر هكذ

ترحيل او استدعاء رائع ''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''' Sub NAGEH() ''هذا الكود للعبقري ياسر العربي حفظه الله '' تم هذا الكود بتاريخ 8 / 10/ 2016 ''الهدف من الكود هو استدعاء بيانات ''شرح الكود '' Dim myArray, lr, X, targt, targt1, targt2, targtN Dim SERCH As Worksheet, DATA As Worksheet '____________________________________________ Set DATA = Worksheets("رصد الترم الثانى") 'اسم شيت المصدر Set SERCH = Worksheets("كشف ناجح") 'اسم الشيت الهدف '____________________________________________ Range("A8:R1000").Clear 'النطاقات متغيره Range("B7:R7").AutoFill Destination:=Range("B7:R" & Range("A4").Value + 6), Type:=xlFillDefault lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row + 2 'اخر صف به بيانات 'رقم عمود البدايه اللي بعد المسلسل ' متغير SERCH.Range("C7:N" & SERCH.Cells(Rows.Count, 3).End(xlUp).Row + 1).ClearContents 'مسح نطاق البحث القديم targt = "له* دور ثان في" 'معيار البحث 'نطاق قاعدةالبيانات المصدر الذي سيتم البحث فيه myArray = DATA.Range("A7:EF" & lr) '____________________________________________ 'عدد الاعمده في الجدول في صفحه الهدف ReDim Y(1 To lr, 1 To 13) For X = 1 To lr - 6 If targt = "" Then Exit Sub 'رقم عمود معيار البحث If myArray(X, 101) Like targt & "*" Then rw = rw + 1 'For ww = 1 To 102 ' Y(rw, ww) = myArray(X, ww) ' Next ww 'العمود التاني بعد المسلسل Y(rw, 1) = myArray(X, 2) 'العمود الثالث بعد المسلسل Y(rw, 2) = myArray(X, 3) 'العمود الرابع بعد المسلسل Y(rw, 3) = myArray(X, 13) 'العمود الخامس بعد المسلسل Y(rw, 4) = myArray(X, 22) 'العمود السادس بعد المسلسل وهكذا Y(rw, 5) = myArray(X, 31) Y(rw, 6) = myArray(X, 40) Y(rw, 7) = myArray(X, 51) Y(rw, 8) = myArray(X, 52) Y(rw, 9) = myArray(X, 82) Y(rw, 10) = myArray(X, 101) Y(rw, 11) = myArray(X, 102) ' Y(rw, 12) = myArray(X, 110) ' Y(rw, 13) = myArray(X, 111) End If Next X If rw > 0 Then SERCH.Cells(Rows.Count, 3).End(xlUp)(2, 1).Resize(rw, 13).Value = Y() End Sub ترحيل الدور التاني5.rar

سلام شباب لا يا سيدي ، مو نفس الشئ!! اذا اردت ان تضع معادلاتك ، فضعها في الاستعلام (لسرعة عمل برنامجك) ، ولا تضعها في الحدث في التقرير (تابع معي الموضوع لوسمحت) . في برنامجك المرفق ، في التقرير ، عندك كود في حدث التفصيل: . ولما تفتح التقرير ، النتيجة هكذا: . الآن اوضح لك الشئ اللي انت لا تراه ، واللي يبطئ سرعة برنامجك: نضع في نفس التقرير هذا الكود ، وعمله عداد فقط ، يخبرنا كم مرة يقوم التقرير بعمل المعادلات الحسابية . والنتيجة . يعني الكود يقوم بعمل المعادلات الحسابية 18 مرة (بعدد السجلات الظاهرة في صفحة التقرير) ، ولما تنتقل الى الصفحة التالية ، فانه يقوم بنفس الشئ!! ها ، قلت لك: لا يا سيدي ، مو نفس الشئ!! جعفر

لا أعلم لماذا تجاهلت سؤالى لمساعدتك ما علينا العينة التى تم العمل عليها مرفقة صورة البرنامج النتائج بأقل من واحد من المائة من الثانية رابط البرنامج بحجم 4.5 ميقا بايت http://up.top4top.net/downloadf-345so1id1-rar.html يمكنك التجربة حتى ملفات تيكست بحجم 100 ميجابايت الى اللقاء 1212 (1).zip

"?*" تعني تحتوي بالحد الادنى على حرف واحد "??*"تعني تحتوي بالحد الادنى على حرفين ... و هكذا

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

جاري التحميل ولكن واضح انه برنامج رائع .. شكرا على مجهودك وبارك الله فيك وزادك من علمه شكرا ،،

::: ممكن اسالك اذا كا هناك اكثر من سجل مشابة لكلمة البحث كيف يكون الحال ؟؟

ترحيل عن طريق القائمه المنسدله للعلامه عبد الله باقشير Sub الديانة() On Error Resume Next H = Range("دين").Value LastRow_1 = Cells(Rows.Count, "B").End(xlUp).Row + 8 Range("B8:AS" & LastRow_1).ClearContents With Sheets("الصف الخامس") S = 8 LastRow_2 = .Cells(.Rows.Count, "E").End(xlUp).Row Application.ScreenUpdating = False For QQ = 12 To LastRow_2 If .Cells(QQ, 3).Value = H Then .Cells(QQ, 2).Range("A1:AS1").Copy Cells(S, 2).PasteSpecial Paste:=xlPasteValues S = S + 1 End If Next End With Application.CutCopyMode = True LastRow_3 = Cells(Rows.Count, "B").End(xlUp).Row ActiveSheet.PageSetup.PrintArea = "$B$1:$AV$" & LastRow_3 ActiveWindow.SelectedSheets.PrintPreview Application.ScreenUpdating = True Application.GoTo [AX4] On Error GoTo 0 End Sub Sub ناجح() On Error Resume Next H = "ناجح" LastRow_1 = Cells(Rows.Count, "B").End(xlUp).Row + 8 Range("B8:AS" & LastRow_1).ClearContents With Sheets("الصف الخامس") S = 8 LastRow_2 = .Cells(.Rows.Count, "E").End(xlUp).Row Application.ScreenUpdating = False For QQ = 12 To LastRow_2 If .Cells(QQ, 47).Value = H Then .Cells(QQ, 2).Range("A1:AS1").Copy Cells(S, 2).PasteSpecial Paste:=xlPasteValues S = S + 1 End If Next End With Application.CutCopyMode = True LastRow_3 = Cells(Rows.Count, "B").End(xlUp).Row ActiveSheet.PageSetup.PrintArea = "$B$1:$AV$" & LastRow_3 ActiveWindow.SelectedSheets.PrintPreview Application.ScreenUpdating = True Application.GoTo [A1] On Error GoTo 0 End Sub Sub دور_تاني() On Error Resume Next H = "دور ثان" LastRow_1 = Cells(Rows.Count, "B").End(xlUp).Row + 8 Range("B8:AV" & LastRow_1).ClearContents With Sheets("الصف الخامس") S = 8 LastRow_2 = .Cells(.Rows.Count, "E").End(xlUp).Row Application.ScreenUpdating = False For QQ = 12 To LastRow_2 If .Cells(QQ, 47).Value = H Then .Cells(QQ, 2).Range("A1:AV1").Copy Cells(S, 2).PasteSpecial Paste:=xlPasteValues S = S + 1 End If Next End With Application.CutCopyMode = True LastRow_3 = Cells(Rows.Count, "B").End(xlUp).Row ActiveSheet.PageSetup.PrintArea = "$B$1:$AW$" & LastRow_3 ActiveWindow.SelectedSheets.PrintPreview Application.ScreenUpdating = True Application.GoTo [A1] On Error GoTo 0 End Sub Sub راسب() On Error Resume Next H = "راسب" LastRow_1 = Cells(Rows.Count, "B").End(xlUp).Row + 8 Range("B8:BA" & LastRow_1).ClearContents With Sheets("الصف الخامس") S = 8 LastRow_2 = .Cells(.Rows.Count, "E").End(xlUp).Row Application.ScreenUpdating = False For QQ = 12 To LastRow_2 If .Cells(QQ, 47).Value = H Then .Cells(QQ, 2).Range("A1:AZ1").Copy Cells(S, 2).PasteSpecial Paste:=xlPasteValues S = S + 1 End If Next End With Application.CutCopyMode = True LastRow_3 = Cells(Rows.Count, "B").End(xlUp).Row ActiveSheet.PageSetup.PrintArea = "$B$1:$BB$" & LastRow_3 ActiveWindow.SelectedSheets.PrintPreview Application.ScreenUpdating = True Application.GoTo [A1] On Error GoTo 0 End Sub ترحيل عن طريق القائمة المنسدله.rar

الاخ ابو عصام الغالى وعليكم السلام ورحمة الله وبركاتة اهلا بك بالمنتدى هذا هو ملف الاكسل حاول مع شرح الفيديوهات التجربة مع الملف المرسل مع تعديل البيانات حسب طلبك وعموما انتظر فيديو لشرح كيفية التعديل على الملف والفورم ليناسب موضوعك تابع بافى الفيديوهات مع التطبيق على الملف بعد تعديلة الاخوة الزملاء اليكم الدرس الثالث كيفية عمل زر بحث مع ادخال الاكواد اكواد زر بحث Private Sub TextBox12_Change() Set sh12 = Sheets("بيانات") LR = sh12.[a2000].End(xlUp).Row For Each cl In sh12.Range("a5:a100" & LR) If (Val(Me.TextBox12)) = cl Then Me.TextBox1 = cl.Offset(0, 0) Me.TextBox2 = cl.Offset(0, 1) Me.TextBox3 = cl.Offset(0, 2) Me.TextBox4 = cl.Offset(0, 3) Me.TextBox5 = cl.Offset(0, 4) Me.TextBox6 = cl.Offset(0, 5) Me.TextBox7 = cl.Offset(0, 6) Me.TextBox8 = cl.Offset(0, 7) Me.TextBox9 = cl.Offset(0, 8) Me.TextBox10 = cl.Offset(0, 9) Me.TextBox11 = cl.Offset(0, 10) End If Next End Sub كود زر اغلاق الفورم Private Sub CommandButton4_Click() End End Sub الفيديو ادخال بيانات واستعلام وتعديل وبحث.rar

الف شكر جزاكم الله كل خيراً

تفضل والكود اصبح: Option Compare Database Dim rst As DAO.Recordset Private Sub cmd_Open_desktob_Click() 'On Error Resume Next 'Dim x As FileDialog 'Set x = Application.FileDialog(msoFileDialogFilePicker) 'x.AllowMultiSelect = True 'If x.Show = -1 Then 'For i = 1 To x.SelectedItems.Count 'CurrentDb.Execute "insert into [tbl_emp_wared]([emp_id],[file_loc]) values(" & ID & ",'" & x.SelectedItems(i) & "')" 'Next i 'Me.sfrm_emp_wared.Requery 'End If Dim strFileNames As Variant 'check if the Dir exists If Dir(Me.pate, vbDirectory) = "" Then MsgBox "المسار" & vbCrLf & Me.pate & vbCrLf & _ "غير موجود في الكمبيوتر" & vbCrLf & _ "Sorry, this folder does not exist" Exit Sub End If 'call the open dialog API ' set the Filter for the Multi File Dialog, so it only shows these files 'strFilter = "Image Files " & _ "(*.JPG,*.JPEG,*.JPE,*.GIF,*.BMP,*.DIB,*.TIF,*.TIFF,*.PNG,*.PCX,*.PCD,*.ICO,*.WMF,*.EMF,*.EPS,*.fpx)" & vbNullChar & _ "*.JPG;*.JPEG;*.JPE;*.GIF;*.BMP;*.DIB;*.TIF;*.TIFF;*.PNG;*.PCX;*.PCD;*.ICO;*.WMF;*.EMF;*.EPS;*.fpx" & vbNullChar & vbNullChar strFilter = "All Files " & _ "(*.*)" & vbNullChar & _ "*.*" & vbNullChar & vbNullChar sFolder = "C:\" ' call the API for the Multi File Dialog strFileNames = apiBrowseFiles("Select a File, OR Multiple Files", sFolder, , strFilter) ' user didn't select any file, s/he proceed cancel If UBound(strFileNames) = 0 Then Exit Sub End If SelectedFiles = UBound(strFileNames) ' number of selected files ' take the 1st file name and extract the Folder name from it ' Don't Dim sFolder, it has been declared as Global variable ' so that the last folder visited will be opened again sFolder = strFileNames(1) Do While Right(sFolder, 1) <> "\" sFolder = Left(sFolder, Len(sFolder) - 1) Loop sFolder = Replace(sFolder, "\\", "\") Set rst = Me.sfrm_emp_wared.Form.RecordsetClone ' Add the selected items, and seperate them by a ; so that we use it as Row Source for ' list the files selected in the Listbox lstMultipleFiles For i = 1 To UBound(strFileNames) FileExt = Right(strFileNames(i), 3) File_Path_Name = Replace(strFileNames(i), "\\", "\") File_Name = Replace(File_Path_Name, sFolder, "") ' Copy the original file to Folder in the main Form FileCopy File_Path_Name, Me.pate & "\" & File_Name rst.AddNew rst!name_morfke = File_Name rst!tayp = FileExt rst!File_Check = 2 rst!emp_id = Me.id_m rst.Update Next i End Sub Private Sub cmd_Open_Folder_Click() Dim strFolderName As String Dim strMsg As String If Len(Me.pate & "") <> 0 Then Dim Msg, Style, Response Msg = "مسار الملف موجود ، هل تريد تغيير المسار" & vbCrLf & _ "هل انت متاكد انك تريد الاستمرار في العملية" & vbCrLf & _ "Do you want to continue ?" Style = vbYesNo + vbCritical + vbDefaultButton2 Response = MsgBox(Msg, Style, Title, Help, Ctxt) If Response = vbYes Then strMsg = "رجار اختيار المجلد" & vbCrLf & _ "What Folder you want to select?" strFolderName = BrowseFolder(strMsg) If Len(strFolderName & "") <> 0 Then Me.pate = strFolderName Me.name_folder = Mid(Me.pate, InStrRev(Me.pate, "\") + 1) End If End If Else strMsg = "رجار اختيار المجلد" & vbCrLf & _ "What Folder you want to select?" strFolderName = BrowseFolder(strMsg) If Len(strFolderName & "") <> 0 Then Me.pate = strFolderName Me.name_folder = Mid(Me.pate, InStrRev(Me.pate, "\") + 1) End If End If 'Len 'save this Record, to save the ID, so that the subForm can use it DoCmd.RunCommand acCmdSaveRecord 'now bring the files from the folder Call Make_File_Array End Sub Function Make_File_Array() On Error GoTo err_Make_File_Array 'Folder info Dim File_Count As Integer Dim fdr As Variant Dim Files_Array() As Variant iPath_In = Me.pate iCondition = "*.*" 'No Path, exit If Len(iPath_In & "") = 0 Then Exit Function 'get the file count from the Forlder, and 'place the files in an array fdr = Dir(iPath_In & "\" & iCondition) File_Count = 0 Do While fdr <> "" File_Count = File_Count + 1 ReDim Preserve Files_Array(File_Count) Files_Array(File_Count) = fdr fdr = Dir Loop 'got the folder file count=File_Count, and the files=Files_Array(i) 'SubForm Records 'Dim rst As DAO.Recordset Set rst = Me.sfrm_emp_wared.Form.RecordsetClone rst.MoveLast: rst.MoveFirst RC = rst.RecordCount '1. Make all Records, File_Check=1 (No File) For j = 1 To RC rst.Edit rst!File_Check = 1 rst.Update rst.MoveNext Next j '2. Compare For i = 1 To UBound(Files_Array) 'File_Count iname_morfke = Files_Array(i) itayp = Mid(Files_Array(i), InStrRev(Files_Array(i), ".") + 1) rst.FindFirst "name_morfke='" & iname_morfke & "'" If rst.NoMatch Then 'No Match rst.AddNew rst!name_morfke = iname_morfke rst!tayp = itayp rst!File_Check = 2 rst!emp_id = Me.id_m rst.Update Else 'Matching 'but is it the same extension If rst!tayp = itayp Then 'Matching rst.Edit rst!File_Check = 0 rst.Update Else 'No Match rst.AddNew rst!name_morfke = iname_morfke rst!tayp = itayp rst!File_Check = 2 rst!emp_id = Me.id_m rst.Update End If End If Next i rst.Requery Exit Function err_Make_File_Array: If Err.Number = 3021 Then 'ignor, SubForm is empty Resume Next ElseIf Err.Number = 9 Then 'ignor, SubForm is empty Exit Function Else MsgBox Err.Number & vbCrLf & Err.Description End If End Function Private Sub Form_Current() 'now bring the files from the folder Call Make_File_Array End Sub جعفر 207.2.m.salama.accdb.zip

تعديل بسيط على البرنامج ( في حالة نسبة النجاح 100 % ) 11LA -11LB -11S.rar