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

السلام عليكم 🙂 هذا المنتدى للتبادل العلمي ، حتى يستفيد منه الجميع ، وليس صاحب الموضوع / السؤال فقط 🙂 فيا ريت ان نضع الاجابة بالتفصيل في الرد (سواء الخطوات او الكود او صور من شاشة البرنامج) ، ولا نتوقف عند ارفاق المرفق الذي به الرد / الجواب ، والسبب هو ، حتى يستطيع الجميع رؤية الرد ومعرفته مباشرة ، دون اللجوء الى انزال المرفق وفهمه 🙂 نعم ، هذا عبء إضافي ، ولكن نتائجه ستكون مثمرة ان شاء الله 🙂 وتذكروا ، هذا مجرد طلب ورجاء ، وليس اجباري 🙂 شكرا جزيلا 🙂 جعفر

مثال أولي قابل للتطوير بانتظار تجاربكم ومراجعاتكم بخيرها وشرها 🙂 PeriodsPrepare_01.accdb

Remove all the code in ThisWorbook module before executing the following code. Also make the worksheet you desire to copy to be Active Sub Test() Dim ws As Worksheet, sh As Worksheet, sName As String, cnt As Long Set ws = ActiveSheet cnt = 1 If InStr(ws.Name, "-") Then sName = Left(ws.Name, 3) & Right(Year(Date), 2) Else MsgBox "Worksheet Name Should Have A Hyphen", vbExclamation: Exit Sub End If Do While SheetExists(sName & "-" & cnt) = True cnt = cnt + 1 Loop If cnt > 12 Then MsgBox "The Number of Copies Has Reached Its Limit.", vbExclamation: Exit Sub End If ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) Set sh = ActiveSheet sh.Name = sName & "-" & cnt End Sub Function SheetExists(ByVal sheetName As String) As Boolean Dim ws As Worksheet On Error Resume Next Set ws = ThisWorkbook.Sheets(sheetName) On Error GoTo 0 If ws Is Nothing Then SheetExists = False Else SheetExists = True End Function

السلام عليكم ورحمة الله وبركاته .. في ليلة صافية والجو بين البارد والمعتدل .. وأنا أتصفح الفيس بوك .. لمحت سؤال لأحد الإخوة يطلب فيه طريقة لحساب عدد أيام الغياب والحضور للموظفين في نموذج مستمر .. فخطرت على بالي هذه الدالة الصغنونه الظريفة .. فوضعتها موضع التنفيذ مع نموذج دايناميكي لتقويم شهري كنت قد صممته سابقا مع سبق الترصد 😁 وقلت أضعه بين أيدي جنابكم لمن أراد أن يستفيد منه .. ولمن أراد أن ينفعنا بنصائحه الثمينة والسمينة 😅🖐🏼️ وهذه هي الدالة المستخدمة في عمودي مجموع الحضور والغياب : Public Function Count_Present_Absent(P_or_A As String) As Integer ' دالة لحساب عدد أيام الحضور وعدد أيام الغياب من تقويم مكون من 31 يوم ' By: Moosak 'P_or_A = Present or Absent ? وتعني أنت تريد حساب الحضور أم الغياب ' على أفتراض أن أسماء حقول الأيام هي على التوالي : Day1, Day2, Day3 ...... Dim x As Integer Dim Frm As Form: Set Frm = Screen.ActiveForm Dim PresentDays As Integer, AbsentDays As Integer Count_Present_Absent = 0 For x = 1 To 31 If Frm.Controls("Day" & x).Value Like "*ح*" Then ' حساب عدد أيام الحضور PresentDays = PresentDays + 1 ElseIf Frm.Controls("Day" & x).Value Like "*غ*" Then ' حساب عدد أيام الغياب AbsentDays = AbsentDays + 1 End If Next ' الدالة ترجع مجموع عدد أيام الحضور أو مجموع عدد أيام الغياب حسب الطلب If P_or_A = "P" Then Count_Present_Absent = PresentDays ElseIf P_or_A = "A" Then Count_Present_Absent = AbsentDays Else Set Frm = Nothing Exit Function End If Set Frm = Nothing End Function موضوع سريع وعلى الطاير قبل أن تتفلت المعلومات 😊🖐🏼️ تسجيل حضور وغياب الموظفين.accdb

اخى اكتب انت اسم الورقة Private Sub CreateSheet() Dim ws As Worksheet ss = InputBox("name is ........") Set ws = Sheets.Add(After:=Sheets(Sheets.Count)) ws.Name = ss End Sub

الف الف مبرووووووووك اعتذر عن التأخيـــــــــــــــر

مبروك موسى لا حول ولا قوة الا بالله نتمى لك التوفيق والاستمرار بالعطاء ولا اظن لها تقصير يؤثر انا من متاتبعينك نادر من يحصل على هذا الشرف لملاحظة كبار السن يدل على المحبة اعانك الله وبالتوفيق

اخي ... بالفعل هذا ماتم عملة في المشاركة الاولي وعلي العموم تفضل الملفطباعة اعمده محدده.xlsm

الحمد لله

السلام عليكم تفضل الشيت بعد التعديل يعمل جيدا Test2.xlsm

السلام عليكم تم الدمج بعد التاكد من كون الحسابين لك

That's what my code do exactly. Review the code well

السلام عليكم و رحمة الله اخوتى و أحبتى اعضاء منتدى اوفيسنا الحقيقة ترددت كثيرا قبل كتابة هذا الموضوع و لعدة اسابيع و لكنى اليوم قررت ان ارتدى ثوب الشجاعة و اقدم اليكم ذلك البرنامج المتواضع و الذى كلفنى جهدا ليس بالقليل و قد اوحى الى فكرته حفيدى مازن لذا قررت ان اسمى البرنامج باسمه و فكرة البرنامج هو استعراض حروف و كلمات اللغة العربية البسيطة و التى تناسب عقلية تلميذ كى جى 1 و كى جى 2 مدعوما بالصور التى قد يعرفها الطفل فى ذلك العمر ملحوظة هامة : لابد من دعم الابوين حتى يتعلم الطفل استخدام البرنامج بنفسه و الآن على بركة الله .... اليكم البرنامج ( بعد فك الضغط لا يتم استخراج اى ملف من الفولدر) Mazen.rar

جزاك الله خيراً ونفع بكم

كل مرة امثلتك تتغير يوجد اخطاء برمجية كثيرة المهم اللي انت تريده حققته لك .. كلها تذهب ضمن بدي الرسالة افتح المثال وجرب ارسل وشوف بريدك تجرية11.rar

تعديل على التعديل السابق 🙂 التعديل السابق لتقريب الكسور إلى أقرب رقم صحيح كان يحول الخلايا الفاضية إلى أصفار وهذا خطأ لأن البرنامج يفرق بين الصفر والتي هي درجة تحصيل والخانة الفاضية والتي كان يعتبرها البرنامج غياب. التعديل في هذا السطر: من If IsNumeric(.Value) Then إلى If .Value <> "" And IsNumeric(.Value) Then توزيع القرار لمدارس العراق_06.xlsm

تم تعديل الكود الى frmMyUserForm.Show vbModeless DoEvents --- --- --- --- Unload frmMyUserForm واصبح كل شي تمام الحمد لله

مبــــروك أخي الكريم تستـــــــــــــــــــــــــــــاهل كل خير أعانكـــــــــــــم الله على حمل المسؤولية

ومشاركة مع اخي موسى يتم تعريف متغير عام .. ويتم تغيير قيمة المتغير من النموذج عند فتح التقرير If hedAPage = 1 Then Me.PageHeaderSection.Visible = False Me.PageFooterSection.Visible = False End If اخي موسى لاحظ اننا كنا نعمل على الاجابة في الوقت نفسه Database4.accdb

وعليكم السلام أخي @حامل المسك 🙂 لاحظ أن لرأس وتذييل الصفحة خصائص وإعدادات خاصة بها مثلها مثل بقية العناصر .. لذلك يمكنك التحكم بها أيضا بالكود .. كما تتحكم بالعناصر الأخرى عن طريق مناداتها باسمها .. ______________________________________________________________ وعليه يمكنك كتابة كود بشرط .. ( مثلا تعمل في النموذج ==> )

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

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

تفضل صديقي هذا طلبك ابو طارق.accdb

تفضل أخي أزهر 🙂 (1) هذه الأكواد الاثلاثة لأزرار [إضافة ملف] و [فتح الملف] و [حذف الملف] : Private Sub AddFilesBtn_Click() '================================================================ هذا الجزء يوضع على الزر الذي يضيف الملف Dim file As String Dim fileName As String Dim SavePath As String If Me.NewRecord Then MsgBox "أكتب التفاصيل أولا", vbOKOnly, "": Exit Sub file = selectFile If IsBlank(file) Then Exit Sub fileName = GetFileName(file) SavePath = BECurrentPath & "attachments\" & [ID] & "\" & fileName ' يتم حفظ الملف في مجلد المرفقات بجانب قاعدة البيانات في مجلد بنفس رقم الآيدي MkDir (BECurrentPath & "attachments\") MkDir (BECurrentPath & "attachments\" & [ID] & "\") FileCopy file, SavePath ' حفظ المسار في مربع النص Me.filepath = fileName Me.Refresh MsgBox "تم إضافة الملف بنجاح" End Sub '================================================================ هذا الجزء يوضع على الزر الذي يفتح الملف Private Sub BrowserBtn_Click() On Error GoTo ErrorFix If Not IsBlank(Me.filepath) Then If IsFileExists(Me.filepath) = False Then MsgBox "لا يمكن العثور على الملف" Else OpenPath Me.filepath End If Exit Sub Else MsgBox "لا يوجد مرفقات" Exit Sub End If ErrorFix: If Err.Number = 0 Then On Error Resume Next Else MsgBox Err.Number & "\\\" & Err.Description End If End Sub '================================================================ هذا الجزء يوضع على زر الحذف Private Sub DeletBtn_Click() On Error GoTo whathapen If MsgBox("هل أنت متأكد من رغبتك في حذف المرفق ؟", vbYesNo, "تأكيد الحذف") = vbYes Then Else Exit Sub End If If Not IsBlank(Me.filepath) Then If IsFileExists(Me.filepath) = False Then MsgBox "لا يمكن العثور على الملف" Exit Sub Else DleteFolder BECurrentPath & "attachments\" & [ID] Me.Attachment = "" MsgBox "تم حذف الملف" Exit Sub End If Else MsgBox "لا توجد مرفقات" Exit Sub End If whathapen: If Err.Number = 53 Then MsgBox "لا توجد ملفات لحذفها" Exit Sub ElseIf Err.Number = 0 Then On Error Resume Next Else MsgBox Err.Number & "\\\" & Err.Description End If End Sub (2) وهذه الأكواد ضرورية لتشغيل الأكواد السابقة .. ضعها في موديول منفصل : Public Function selectFile() On Error GoTo ErrHandler Dim fd As FileDialog Dim filedialogPath As String Set fd = Application.FileDialog(msoFileDialogFilePicker) fd.AllowMultiSelect = False fd.Title = "حدد الملف المطلوب" ' fd.InitialFileName = CurrentProject.Path fd.Filters.Clear fd.Filters.Add "كل الملفات", "*.*" If fd.Show = True Then selectFile = fd.SelectedItems(1) ' Exit Function Else MsgBox "لم تقم باختيار أي ملف" Exit Function End If ErrHandler: If Err.Number = 0 Then Exit Function Else MsgBox "Error Number : " & Err.Number & " :::: " & Err.Description ' End If End Function Public Function IsBlank(arg As Variant) As Boolean Select Case VarType(arg) Case vbEmpty IsBlank = True Case vbNull IsBlank = True Case vbString IsBlank = (LenB(arg) = 0) Case vbObject IsBlank = (arg Is Nothing) Case Else IsBlank = IsMissing(arg) End Select End Function Public Function GetFileName(txtPath As String) As String ' To Extract File Name From A given Path GetFileName = Right(txtPath, Len(txtPath) - InStrRev(txtPath, "\")) End Function Public Function IsFileExists(txtPath As String) As Boolean ' To check whether a given file or folder exists or not If Len(Dir(txtPath, vbDirectory)) = 0 Then IsFileExists = False Else IsFileExists = True End If End Function Public Sub OpenPath(strpath As String) Shell "explorer.exe" & " " & strpath, vbNormalFocus End Sub Public Function DleteFolder(FolderPath As String) Dim fs As Object Set fs = CreateObject("Scripting.FileSystemObject") fs.DeleteFolder FolderPath, True Set fs = Nothing End Function Public Function BECurrentPath() On Error GoTo ErrHandler Dim FullLinkedPath As String Dim LinkedDBPath As String FullLinkedPath = Nz(DLookup("Database", "MSysObjects", "Type=6"), "") If FullLinkedPath <> "" Then LinkedDBPath = Left(FullLinkedPath, InStrRev(FullLinkedPath, "\") - 1) BECurrentPath = LinkedDBPath & "\" Else BECurrentPath = CurrentProject.Path & "\" End If ErrHandler: If Err.Number = 0 Then Exit Function Else MsgBox "Error Number : " & Err.Number & " :::: " & Err.Description End Function

اخي معني هذا الخطأ #N/A .... يعني الاسم التي تبحث عنة غير موجود ... تم حل الخطأ ... اختار الاسم من القائمة المنسدلة تفضل Test.xlsx

=IFERROR(VLOOKUP(@$A$2:$A$6,Sheet2!$A$1:$B$6,2,0),"")

اخي علي بن علي تفضل طباعة اعمدة محددة مع صفوف اعتمادا على قيمة نصية+111.xlsb.xlsm

Draw a button inside cell B9 or any other cell that will be visible all the time and assign the following macro to that button. The code is flexible and you can assign the desired columns to be shown and also to assign the rows you would like to hide Sub Test() Dim desiredColumns(), aRows(), e, ws As Worksheet, columnsHidden As Boolean, lastColumn As Long, i As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Sheets(1) With ws desiredColumns = Array(2, 3, 7, 9, 10, 13, 15, 20, 23) aRows = Array("1:8", "25:27") lastColumn = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column If Not columnsHidden Then .Columns(lastColumn + 1).Resize(, .Columns.Count - lastColumn).EntireColumn.Hidden = True For i = 1 To lastColumn If Not IsInArray(i, desiredColumns) Then .Columns(i).EntireColumn.Hidden = True End If Next i For Each e In aRows .Rows(e).EntireRow.Hidden = True Next e columnsHidden = True .PrintPreview .Activate GoTo iLine Else iLine: .Columns.EntireColumn.Hidden = False For Each e In aRows .Rows(e).EntireRow.Hidden = False Next e columnsHidden = False End If End With Application.ScreenUpdating = True End Sub Function IsInArray(ByVal valToBeFound, ByVal arr) As Boolean Dim ele For Each ele In arr If ele = valToBeFound Then IsInArray = True: Exit Function Next ele IsInArray = False End Function

تفضل اخي ابو طارق 4you.accdb

تعديل آخر حسب فهمي Calculate_astalt_03.accdb

تفضل 🙂Encode_Decode.zip

السلام عليكم ورحمة الله وبركاته أخي الكريم أبو عاصم: هل يمكنني التواصل بك على الخاص إن كان لديك رقم واتساب فأنا في انتظاره أو أي وسيلة تواصل أخرى تراها أنت

ActiveWindow.SelectedSheets.PrintOut From:=1, To:=1, Copies:=1, Collate _ :=True, IgnorePrintAreas:=False يمكنك استخدام الكود السابق حيث from اول صفحة يتم طباعتها و To اخر صفحة يتم طباعتها

يدوياً؟ قم باختيار الجدول ( ليس من الخلايا وإنما كامل الأسطر) بمعني اضغط على الرقم 1 بجانب الخلية A1 نزولا حتى آخر الجدول) ثم CTR+ Copy ثم right click على أول خلية تريد النسخ فيها وقم باختيار (Insert Copied cells) ويمكن عمل ذلك بماكرو إذا أحببت

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

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

بسم الله الرخمان الرحيم السلام عليكم ورحمة الله وبركاته لاحظتُ من خلال تصفحي للمنتدى شح المعلومات عن عنصر التحكم List View على عكس list Box برغم انه يمكن التعامل مع الاولى مثلما نتعامل مع List Box لذى بادرت بهذا المرفق الذي جمعت فيه ما استطعت من معلومات لكيفية التعامل مع ListView أرجو ان اكون قد وفقت ولو قليلا في شرح هذه الاداة كما ارجو ان تعم فائدته الجميع ملاحضة هامة المشكلة الوحيدة في عنصر التحكم ListView هي انه يمكن ان يحدث خطأ أثناء فتح الملف وذالك لعدم توافق النسخة المستعملة في المرفق مع النسخة التي عند الذي يحدث عنده الخطاء لذلك ارفقت ملفين احدهما يحوي الشرح للاكواد فقط دون امثلة عملية اما الثاني يحوي الامثلة العملية مع تحيات اخوكم في الله شوقي ربيع درس في التعامل مع istviewبدون امثلة عملية.rar درس في التعامل مع istview 2007 مع امثلة عملية.rar

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