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

الدرس الأول: مولد الباركود أول خطوة لمعرفة كيفية قراءة الباركود هو طريقة توليدها ومن ثم ربطها بالبرنامج. تختلف صياغة الباركود نظراً للكود الذي يتبعه والتي تحدد معايير رسم وقراءة رموز الباركود، مثل كود 93 و كود 39 وكود 128، ولهذا السبب يشتكي البعض من عدم تمكنه من قراءة رموز الباركود، ولهذا في هذا الدرس سنعتمد على كود 128 وكود QR لأنهما الأكثر شيوعاً وتقبل معظم الأجهزة.. هناك برامج ومواقع كثيرة تقوم بتوليد الباركود، ونحن في هذا الدرس قمنا بتوليد الباركود عن طريق موقع خارجي من خلال المرفق التالي. barcode generator.rar

ارجو ان يكون هذا هو المطلوب المصنف1.rar

بسم الله الرحمن الرحيم الحمد لله رب العالمين والصلاة والسلام على اشرف المرسلين سيدنا محمد وعلى اله وأصحابه اجمعين بفضل الله وكرمة انتهيت من تطوير برنامج المصروفات الاصدار الثالث . وقد تم هذا التطوير بناء على رغبة الكثيرون والجديد فيه -زيادة عدد الحسابات الى 100 حسابات وزيادة عدد حركات التسجيل الى الضعف - امكانية عرض تقرير مصروفات لقسم معين ولفتره معينه - امكانية عرض تقرير سنوي - عمل نسخة احتياطيه للبرنامج تم عمل حماية للملف حفاظا على المعادلات والصيغ من التلف والباسورد 12345 ارجو من كل من يستفاد من هذا البرنامج نشره ومشاركته للجميع فزكاة العلم نشره الاصدارت السابقه الاول والثانى على على هذا الرابط http://www.officena.net/ib/index.php?showtopic=54319&hl= برنامج المصروفات الاصدار الثالث.rar

السلام عليكم 1. من المعروف ان تنسيق النص في مربع القائمة ListBox هو من اليسار الى اليمين ، مشكلة كانت تصادفني دائما ، وهو تنسيق القيم في مربع القائمة لتكون من اليمين الى اليسار بالنسبة للغة العربية (طريقة تغيير مربع القائمة الى مربع تحرير ونص ، ثم عمل التنسيق عليه من اليمين الى اليسار ، ثم اعادته الى مربع قائمة لا يعمل معظم الوقت) ، موقع http://www.lebans.com والذي يحتوي على مالذ وطاب عنده طريقه لهذا التنسيق: http://www.lebans.com/justicombo.htm كذلك. 2. ونفس المشكلة مع موضوع تنسيق الشجرة TreeView من اليمين الى اليسار. النتيجة: و وطريقة العمل ، يوضع هذا الكود في وحدة نمطية: Option Compare Database Option Explicit #If VBA7 And Win64 Then '64 bits Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Long, ByVal bErase As Long) As Long Public Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr Public Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr Public Declare PtrSafe Function GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As LongPtr Dim hwnd As LongPtr #Else '32 bits Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Public Declare Function GetFocus Lib "user32" () As Long Public Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long Dim hwnd As Long #End If Public Const GW_CHILD = 5 Public Const WS_EX_LAYOUTRTL = &H400000 Public Const GWL_EXSTYLE = (-20) Function RTL_Set(frm As Form, ctl As Control) Dim varHwnd As Variant Dim OldLong As Long frm.SetFocus ctl.SetFocus varHwnd = GetFocus() OldLong = GetWindowLong(varHwnd, GWL_EXSTYLE) SetWindowLong varHwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL InvalidateRect hwnd, 0, False End Function Function RTL_SetTree(frm As Form, ctl As Control) Dim OldLong As Long OldLong = GetWindowLong(ctl.hwnd, GWL_EXSTYLE) SetWindowLong ctl.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL InvalidateRect hwnd, 0, False End Function ' ' From http://www.microsoft.com/middleeast/msdn/faq.aspx ' 'Place OnLoad of the Form ' Dim OldLong As Long 'For Form ' OldLong = GetWindowLong(Me.hwnd, GWL_EXSTYLE) ' SetWindowLong Me.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For List ' OldLong = GetWindowLong(List1.hwnd, GWL_EXSTYLE) ' SetWindowLong List1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For The StatusBar ' OldLong = GetWindowLong(StatusBar1.hwnd, GWL_EXSTYLE) ' SetWindowLong StatusBar1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For TreeView ' Dim nodX As Node ' Set nodX = TreeView1.Nodes.Add(, , "R", "Root") ' Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C1", "Child 1") ' Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C2", "Child 2") ' Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C3", "Child 3") ' Set nodX = TreeView1.Nodes.Add("R", tvwChild, "C4", "Child 4") ' nodX.EnsureVisible ' OldLong = GetWindowLong(TreeView1.hwnd, GWL_EXSTYLE) ' SetWindowLong TreeView1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For ListView ' OldLong = GetWindowLong(ListView1.hwnd, GWL_EXSTYLE) ' SetWindowLong ListView1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For ProgressBar ' ProgressBar1.Value = 50 ' OldLong = GetWindowLong(ProgressBar1.hwnd, GWL_EXSTYLE) ' SetWindowLong ProgressBar1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False 'For ToolBar ' mhwnd = GetWindow(Toolbar1.hwnd, GW_CHILD) ' OldLong = GetWindowLong(mhwnd, GWL_EXSTYLE) ' SetWindowLong mhwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL ' InvalidateRect hwnd, 0, False في اسفل الكود انا تركت الكود لبقية الاشياء اللي يمكن عملها من اليمين الى اليسار. اما تنفيذ التنسيق لمربع القائمة ، فهو وضع هذا الكود عند تحميل النموذج الذي يحتوي على هذا المربع (وهنا اسم حقل مربع القائمة هو List0_RTL ) : 'ListBox RTL Call RTL_Set(Me, List0_RTL) وتنسيق الشجرة ، فهو وضع هذا الكود عند تحميل النموذج الذي يحتوي على الشجرة (وهنا اسم الشجرة هو TreeView1) : 'TreeView RTL Call RTL_SetTree(Me, TreeView1) وللأمانة العلمية ، فاني استخدم قاعدة البيانات التي وضعها الاخ محمد في الرابط: http://www.officena.net/ib/index.php?showtopic=60781 جعفر تعديل 1: 18-11-2021 ، جعل البرنامج يعمل على النواتين 32بت و 64 بت 54.RTL_TreeView_ListBox_32bits_n_64bits.accdb.zip

السلام عليكم ورحمة الله وبركاته اخوانى الافاضل تحية طيبة وبعد .................................................... ومازلنا مع conditional formatting ......................... اليوم سوف نقدم درسا جديدا فى كيفية تلوين السطور الفرديه والزوجيه داخل نطاق محدد اولا نبدأ بتلوين السطور الفرديه كما يتضح من الصوره الاتيه نقوم بتحديد النطاق من a4:d20 ثم نتبع الشرح الاتى =MOD(ROW(),2) الان قم بتطبيق المثال على ملف من عندك وستلاحظ النتيجه بنفسك ارجو ان تتقبلو تحياتى.

وعليكم السلام حول البرنامج الى mde او accde بالطريقة هذه ، غير ممكن الحصول على الكود (لقسم منا ) ، وشفّر بيانات الجداول ، فحتى لو استطاعوا الوصول لداخل البرنامج (قسم منا ) ، فلن يستفيدوا من البيانات ، جعفر

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

أساتذتى الكرام كل الاحترام والتقدير لكم مرفق اضافه للاكسيل Addin وعندما حاولت الدخول على محرر الاكواد لها وجدت انها غير مرئية Project Unviewable لم أفهمها ولا اعرف ما هذا ؟؟؟ هل من مساعده ؟ GM Tools.rar

اللهم امين اشكرك اخى الكريم جزاكم الله خيرا على دعاؤكم لى

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

بسم الله الرحمن الرحيم التصفيه حسب التاريخ Sub FiltreSurDate() Dim DLig As Long, StartDate As Long, EndDate As Long Application.ScreenUpdating = False With Sheets("ورقة1") .Activate DLig = .Range("A" & Rows.Count).End(xlUp).Row If .FilterMode = False Then .Range("A1:G1").AutoFilter Else .Range("A1:G1").AutoFilter Field:=6 End If StartDate = DateValue("01/01/2010") EndDate = DateValue("31/12/2010") .Range("A1:G1").AutoFilter Field:=6, Criteria1:=">=" & StartDate, Operator:=xlAnd, Criteria2:="<=" & EndDate .Range("A1:G" & DLig).Copy Destination:=.Range("A10") End With Application.ScreenUpdating = True End Sub

أخي مختار.. الظاهر إنك كسرت علي الباب وأنا قاعد أجهز الدرس.. المرة الجاية راح أشتغل بعيد عن الباب.. تحياتي القلبية

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

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

استاذى الحبيب تفضل المرفق تم اضافه زر جديد يقوم باحضار كل العملاء طبقا لتاريخ استحقاق من فترة الى فترة لاحظ حضرتك انى ظللت خلايا باللون الاحمر ارى لا فائده منها فبأمكانك اختيار الفترة من الخلايا G4/G5 اذن فى زرين مع حضرتك زر يقوم بجلب حركات على عميل معين طبقا لفترة محدده وزر اخر يقوم بجلب حركات جميع العملاء طبقا لتاريخ الاستحقاق حسب فترة معينه ارجوا ان يكون المطلوب تقبل تحياتى TAS.zip

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

الأخ الكريم أبو يوسف لم ترفق ملف فعملت على الملف المرفق الذي تفضل به الباشمهندس طارق النتائج في العمود L ..تم عمل كود ليجمع البيانات من الأعمدة ثم حذف الأرقام التي لا تطابق الشرط Sub CopyAllToOneColumn() Dim lCol As Long, lRow As Long Dim LR As Long, I As Long Dim Cell As Range LR = Cells(Rows.Count, 2).End(xlUp).Row lRow = 2 Application.ScreenUpdating = False Range("L2:L1000").ClearContents For lCol = 2 To 10 Cells(lRow, 12).Resize(LR - 1).Value = Range(Cells(2, lCol), Cells(LR, lCol)).Value lRow = Cells(Rows.Count, 12).End(xlUp).Row + 1 Next lCol For I = lRow - 1 To 2 Step -1 If Len(Cells(I, 12)) <> 9 And Len(Cells(I, 12)) <> 12 Then Cells(I, 12).Delete Shift:=xlUp End If Next I Application.ScreenUpdating = True End Sub تقبل تحياتي Delete Numbers Based On Length.rar

الشكر كل الشكر للاســـتاذ طارق محمود والاستــاذ ياسر خليل على هذا الموضوع الرائع والمهم جزاكم الله عنا كل خير جعلكم الله عوناً لنا

الله يجزاك الخير اخوي راعي الغنم

أستاذ ى و أخى ياسر وأنا أيضاُ توصلت للحل أحب أن أشاركم به ضع الكود التالى فى ملف Option Explicit Sub export_data() 'تعريف المتغير من النوع نصي Dim Path As String 'تعريف المتغير من النوع نصي Dim Filename As String Dim Amro As Workbook Set Amro = ThisWorkbook 'تعيين المتغير ليساوي مسار المجلد الذي يحوي المصنفات المراد دمج أوراق العمل منها Path = ThisWorkbook.Path & "\OUTPUT\" 'تعيين المتغير ليساوي اسم كل مصنف من المصنفات التي سيتم التعامل معها Filename = Dir(Path & "*.xls") 'إلغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False 'إلغاء خاصية التنبيه بالرسائل Application.DisplayAlerts = False 'حلقة تكرارية للمصنفات الموجودة في المسار المحدد إلى أن لا يجد أي مصنف بالمسار Do While Filename <> "" 'فتح المصنف Workbooks.Open Filename:=Path & Filename 'نسخ ولصق البيانات Amro.Sheets(1).Range("A1:a2").Copy ActiveWorkbook.Sheets.Select Range("A1").Activate ActiveSheet.Paste Application.CutCopyMode = False 'حفظ وغلق الملفات Workbooks(Filename).Save Workbooks(Filename).Close 'إعادة ضبط المتغير Filename = Dir() Loop 'تفعيل خاصية التنبيه بالرسائل Application.DisplayAlerts = True 'تفعيل خاصية اهتزاز الشاشة 'Application.ScreenUpdating = True End Sub ياعمرو ضع الــــ 1500 ملف فى مجلد باسم OUTPUT جنب ملف شغل الكود ستجد البيانات فى كل ورقه من أو أى ملف من الملفات مها كان عدد الأوراق والملفات تحياتى

تفضل ! افتح التقرير !! بالتوفيق نتيجة الطلبة11.rar

السلام عليكم و رحمة الله و بركاته طلب كيف يتم الغاء ظهور هده الرسالة عند الحفظ في الملف

خلى بالك يا بو سليمان لما نريد نقل بضاعة من مكان الى مكان يلزمنا عربية نقل وسواق شاطر عربية النقل هى الدوال دى نسيبها زى ما هيه فى الملف الرئيسى Public Sub GetData(SourceFile As Variant, SourceSheet As String, _ SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean) Dim rsCon As Object Dim rsData As Object Dim szConnect As String Dim szSQL As String Dim lCount As Long ' Create the connection string. If Header = False Then If Val(Application.Version) < 12 Then szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & SourceFile & ";" & _ "Extended Properties=""Excel 8.0;HDR=No"";" Else szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & SourceFile & ";" & _ "Extended Properties=""Excel 12.0;HDR=No"";" End If Else If Val(Application.Version) < 12 Then szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & SourceFile & ";" & _ "Extended Properties=""Excel 8.0;HDR=Yes"";" Else szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & SourceFile & ";" & _ "Extended Properties=""Excel 12.0;HDR=Yes"";" End If End If If SourceSheet = "" Then ' workbook level name szSQL = "SELECT * FROM " & SourceRange$ & ";" Else ' worksheet level name or range szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];" End If On Error GoTo SomethingWrong Set rsCon = CreateObject("ADODB.Connection") Set rsData = CreateObject("ADODB.Recordset") rsCon.Open szConnect rsData.Open szSQL, rsCon, 0, 1, 1 ' Check to make sure we received data and copy the data If Not rsData.EOF Then If Header = False Then TargetRange.Cells(1, 1).CopyFromRecordset rsData Else 'Add the header cell in each column if the last argument is True If UseHeaderRow Then For lCount = 0 To rsData.Fields.Count - 1 TargetRange.Cells(1, 1 + lCount).Value = _ rsData.Fields(lCount).Name Next lCount TargetRange.Cells(2, 1).CopyFromRecordset rsData Else TargetRange.Cells(1, 1).CopyFromRecordset rsData End If End If Else MsgBox "No records returned from : " & SourceFile, vbCritical End If ' Clean up our Recordset object. rsData.Close Set rsData = Nothing rsCon.Close Set rsCon = Nothing Exit Sub SomethingWrong: MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _ vbExclamation, "Error" On Error GoTo 0 End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Function Array_Sort(ArrayList As Variant) As Variant Dim aCnt As Integer, bCnt As Integer Dim tempStr As String For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1 For bCnt = aCnt + 1 To UBound(ArrayList) If ArrayList(aCnt) > ArrayList(bCnt) Then tempStr = ArrayList(bCnt) ArrayList(bCnt) = ArrayList(aCnt) ArrayList(aCnt) = tempStr End If Next bCnt Next aCnt Array_Sort = ArrayList End Function السواق ( لازم يكون شاطر ولو خايب نغيره ) احنا بقى السواق بتاعنا هو الكود ده Sub GetData_bymokhtar() GetData ThisWorkbook.Path & "\bosoliman1.xls", "_4300", "A1:a", Sheets("الرئسية").Range("A2"), True, True GetData ThisWorkbook.Path & "\bosoliman2.xls", "_6050", "A1:a", Sheets("الرئسية").Range("i2"), True, True GetData ThisWorkbook.Path & "\bosoliman3.xls", "_8011", "A1:a", Sheets("الرئسية").Range("q2"), True, True GetData ThisWorkbook.Path & "\bosoliman4.xls", "_TASI", "A1:a", Sheets("الرئسية").Range("y2"), True, True GetData ThisWorkbook.Path & "\bosoliman5.xls", "81401", "A1:a", Sheets("الرئسية").Range("ag2"), True, True End Sub لاحظ أن السواق يجب أن يكون عارف هو بيحمل ايه وعدده كام عشان ده بيفرق فى الأجره بص فى الكود كده هتلاقى خمس سطور بعدد الملفات اللى هنحمل منها بضاعة كل سطر خاص بملف فى أى سطر من الخمسة بنقول للسواق : من الملف الذى اسمه كذا اللى فى مسارك حمّل المدى الفلانى ( من الخلية .... الى الخلية ....) من الشيت اللى اسمه .......وتعالى حطه فى ملف الرئيسية اعتبارا من الخلية ...... بس كدا خلاص البضاعة وصلت ==== قسمنا البيان ده 12/30/2007,38.70,39.00,36.70,38.30,86849042,38.30 بدالة StrSplit دى Function StrSplit(InString, Pos, Delim) StrArray = Split(InString, Delim) StrSplit = StrArray(Pos - 1) End Function نستعملها ازاى : قف خلية اضغط fx عند شريط المعادلات هتلاقى الاكسل بيقولك أدرج داله اختر من القائمة المنسدلة user defined مثال =IF(A2="";"";StrSplit(A2;1;",")) دى تعطيك الجزء الأول من الرقم =IF(A2="";"";StrSplit(A2;2;",")) دى تعطيك الجزء الثانى من الرقم =IF(A3="";"";StrSplit(A3;3;",")) دى تعطيك الجزء الثالث من الرقم وهكذا بعد ما تخلص من المعادلة شدها لتحت وتوتة توتة فرغت الحدوتة حلوة ولا ملتوتة

الاخ الكريم رجب الكود شغال بشكل طبيعي ، لكن تكمن المشكلة في الملف نفسه الأخ صاحب الملف عامل حاجة اسمها Print Area هتقوم بالغاء الـ Print Area من التبويب Page Layout ثم Print Area ثم Clear Print Area نفذ الكود وشوف النتيجة ، ومتنساش تدعي لي يا رجب

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

الأخ الفاضل أبو البراء إليك الملف التالي عله يفي بالغرض R&L.rar

وعليكم السلام المعادلات موجودة في العمود k تفضل R&L#1.rar

يبدو أن السبب في تكراره أخي الكريم لأنك تدرج اسم الكتاب والحقول الأخرى فارغة أي أنه من المفترض أن تدرج الـ (نوع الصادرة - السنة - تسلسل الصادرة) قبل اسم الكتاب يعني تجعل اسم الكتاب آخر شيء لكي يعمل الكود

تفضل الاوائل على تقرير ترتيب الطلبة تقرير.rar

أخي الكريم مصطفى يرجى تكبير حجم الخط قليلاً (النظر ضعيف ..) وأمر آخر لا تكتب كلمة طلب أو مساعدة أو عاجل أو أي من هذه الكلمات في عنوان الموضوع (تم التعديل وحذف كلمة طلب) جرب هذا الكود ..يقوم بطباعة الأوراق المخفية والظاهرة ..جميع أوراق العمل كافة Sub Print_Hidden_And_Visible_Worksheets() Dim CurVis As Long Dim sh As Worksheet For Each sh In ActiveWorkbook.Worksheets With sh CurVis = .Visible .Visible = xlSheetVisible .PrintOut .Visible = CurVis End With Next sh End Sub تقبل تحياتي

الأخ الفاضل أبا اسماعيل شوف الفيديو التالي فيه حل لمشكلتك

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

أخي الفاضل.. جرب المرفق بعد إضافة هذا الكود في حدث عند الخروج من الحقل nambook Dim rst As Recordset Set rst = Me.RecordsetClone rst.MoveFirst Do Until rst.EOF If rst![seq] = Me![seq] And rst![typ] = Me![typ] And rst![year1] = Me![year1] And rst!nambook = Me!nambook Then MsgBox " هذا الكتاب مكرر بنفس الإسم والسنة والرقم التسلسلي ", vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading, " تنبيه لا يمكن تسجيله" Me.Undo DoCmd.CancelEvent [seq].SetFocus Exit Do End If rst.MoveNext Loop rst.Close اتمنى يكون المطلوب sadra----UP.rar

اتفضل هذا هو الكود فى حدث عند الضغط على الزر طباعا انا ظبط الكود من وجهة نظرى على حسب المثال اللى انا عملته | حضرتك تقدر تعدل عليه بالطريقة اللى تعجبك On Error Resume Next If IsNull(nname) Or IsNull(phone) Then DoCmd.CancelEvent Else DoCmd.RunCommand acCmdSaveRecord DoCmd.RunCommand acCmdSelectRecord DoCmd.PrintOut acSelection DoCmd.GoToRecord , , acNewRec End If حفظ وطباعة واضافة سجل جديد.rar

أخي وحبيبي في الله وأستاذي الكبير طارق لكم تشتاق نفسي لرؤية مشاركاتك بالمنتدى ، فمنكم تعلمنا وما زلنا ننهل من علمكم الغزير .. بارك الله فيك وجزاك الله خيراً على هذا الكود المميز والرائع أحببت أن أشارك ولو بشيء بسيط ، مشاركتي مجرد شرح بسيط جداً للكود حتى يستفيد الأخوة الكرام من الكود Sub AddPageBreaks() Dim R As Long, LR As Long 'تحديد رقم آخر صف به بيانات في العمود الأول LR = Sheet1.[A99999].End(xlUp).Row 'إعادة ضبط كل فواصل الصفحات ActiveSheet.ResetAllPageBreaks 'يمكنك استبدال الرقم 15 برقم أول سطر بعد العناوين 'يمثل الرقم 20 عدد الأسطر أو الصفوف المطلوبة في كل صفحة For R = (15 + 20) To LR Step 20 'عمل فاصل للصفحات قبل نهاية كل حلقة تكرارية ActiveSheet.HPageBreaks.Add Before:=Cells(R, 1) 'الانتقال للحلقة التالية Next End Sub تقبل ودي وحبي واحترامي وتحياتي أستاذي ومعلمي الباشمهندس طارق

الدخول ب3 محاولات.وادا كانت لمحاولة ثالثة خطأ يغلق الملف نهائي Private Sub CommandButton1_Click() Static compteur As Byte compteur = compteur + 1 If TextBox1.Value = Sheet1.[A1].Text And TextBox2.Value = Sheet1.[A2].Text Then Unload Me Else If compteur = 3 Then MsgBox "خطاء في كتابةكلمةالسر." & _ vbCrLf & "لايمكنك الدخول للبرنامج" & _ vbCrLf & vbCrLf & "سوف تغادر....", _ vbOKOnly + vbCritical, "كلمةالسر خاطئة" ActiveWorkbook.Close End If MsgBox "كلمةالسرغيرصحيحة." & _ vbCrLf & "ليس لديك الصلاحية للدخول", _ vbOKOnly + vbExclamation, "كلمةالسرخاظئة" TextBox1.Value = "" TextBox2.Value = "" TextBox1.SetFocus Me.Caption = "Entrez le mot de passe. Tentative " & _ compteur + 1 & " sur 3" i = i + 1 If i = 2 Then End End If End If End Sub

مثال تطبيقي: codebarre.rar

اعتقد أنه بعد تفعيل الكود لا يمكن عمل تراجع والحل الوحيل لو حصل خطاء هو إغلاق المصنف دون حفظ والله أعلم

تم التعديل Fadan.rar