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

إخواني الكرام في المنتدى الغالي أقدم لكم اليوم موضوع ليس بالجديد ولكنه جد مفيد (جد .. يعني جداً أوك يا جدو) ..أقصد مفيد جداً الموضوع يتمحور ويتمركز حول معرفة الأرقام المفقودة أو الأرقام الناقصة في سلسلة أرقام .. إليكم الكود الأول المؤدي للغرض (هنا يشترط ترتيب الأرقام) ، مع شرح تفصيلي لأسطر الكود لتتمكن من التعديل عليه Sub MissingNumber_NumbersSorted() 'يقوم الكود بإظهار الأرقام الناقصة في تسلسل معين للأرقام ويشترط ترتيب الأرقام '------------------------------------------------------------------------- Dim SH As Worksheet Dim LR As Long Dim Text As String Dim I As Long, X As Long, XX As Long '[Sheet1] تخصيص المتغير ليساوي ورقة العمل المسماة Set SH = Sheets("Sheet1") 'تحديد آخر صف به بيانات في العمود الأول LR = SH.Cells(SH.Rows.Count, 1).End(xlUp).Row 'حلقة تكرارية بداية من الصف الخامس وحتى آخر صف به بيانات في العمود الأول For I = 5 To LR 'يساوي الفرق بين قيمة الخلية التالية وقيمة الخلية الحالية في الصف المحدد [X] المتغير X = Val(SH.Range("A" & I + 1)) - Val(SH.Range("A" & I)) '[X] استخدام الجملة الشرطية لناتج المتغير Select Case X 'إذا كان الفرق بين قيمة الخليتين أكبر من 1 يتم تنفيذ الحلقة التكرارية ما بين السطرين Case Is > 1 'حلقة تكرارية لتخزين الأرقام الناقصة For XX = 2 To X 'يساوي المتغير نفسه مع قيمة الخلية الحالية مضاف إليها قيمة المتغير في الحلقة التكرارية ناقص واحد ثم سطر جديد[Text]المتغير المسمى 'مثال لفهم هذا السطر '------------------- 'توجد القيمة 50012 [A15] توجد القيمة 50009 وفي الخلية [A14] في الخلية 'بما أن الفرق بين الخليتين يساوي 3 إذاً سيتم تنفيذ الحلقة التكرارية 'بداية الحلقة التكرارية 2 حيث أن رقم 2 هو أول رقم أكبر من واحد ، وفي مثالنا نهاية الحلقة التكرارية تساوي 3 'المتغير المفترض تخزين الأرقام الناقصة فيه عبارة عن سلسلة نصية فيتم إضافة النصوص التي سبق استخراجها ثم إضافة النصوص الجديدة 'الأرقام الناقصة تساوي قيمة الخلية الحالية 50009 في المثال مضافاً إليها قيمة الحلقة التكرارية والتي هنا تساوي 2 في بداية الحلقة التكرارية ليصبح الناتج 50011 ثم ناقص واحد لتحصل على أول رقم ناقص ألا وهو 5010 'يساوي 3 لتحصل في النهاية على الرقم التالي الناقص ألا وهو 5011[XX]مع الانتقال في الحلقة التكرارية يصبح المتغير Text = Text & Val(SH.Range("A" & I)) + XX - 1 & vbCrLf Next End Select Next 'رسالة لإظهار الأرقام الناقصة MsgBox Text, vbMsgBoxRtlReading End Sub وإليكم الكود الثاني وهو أقوى في أنه لا يشترط ترتيب الأرقام Sub MissingNumbers_YK_A() 'يقوم الكود باستخراج الأرقام الناقصة من سلسلة من الأرقام ولا يشترط ترتيب الأرقام '---------------------------------------------------------------------------- Dim InputRange As Range, OutputRange As Range, ValueFound As Range Dim LowerVal As Single, UpperVal As Single, Count_I As Single, Count_J As Single Dim NumRows As Long, NumColumns As Long Dim Horizontal As Boolean On Error GoTo ErrorHandler 'النطاق الذي يحتوي سلسلة الأرقام المراد استخراج الأرقام الناقصة منها Set InputRange = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) LowerVal = WorksheetFunction.Min(InputRange) UpperVal = WorksheetFunction.Max(InputRange) Horizontal = False 'بداية النطاق الذي سيتم استخراج النتائج به Set OutputRange = Range("E2") NumRows = OutputRange.Rows.Count NumColumns = OutputRange.Columns.Count Application.ScreenUpdating = False If NumRows < NumColumns Then Horizontal = True NumRows = 1 Else NumColumns = 1 End If Count_J = 1 For Count_I = LowerVal To UpperVal Set ValueFound = InputRange.Find(Count_I, LookIn:=xlValues, LookAt:=xlWhole) If ValueFound Is Nothing Then If Horizontal Then OutputRange.Cells(NumRows, Count_J).Value = Count_I Count_J = Count_J + 1 Else OutputRange.Cells(Count_J, NumColumns).Value = Count_I Count_J = Count_J + 1 End If End If Next Count_I Application.ScreenUpdating = True Exit Sub ErrorHandler: End Sub كما تمت إضافة حل بمعادلات الصفيف لتؤدي نفس الغرض وإليكم أيضاً كود رائع للأخ الحبيب سليم حاصبيا مع شرح للأسطر ولا يشترط الترتيب للأرقام أيضاً Sub MissingNumbers_SALIM() 'يقوم الكود باستخراج الأرقام الناقصة في سلسلة أرقام ولا يشترط الترتيب '------------------------------------------------------------------ 'تعريف المتغيرات Dim Dico, D Dim C As Range, Rng As Range Dim B As Long, I As Long Dim MinVal As Double, MaxVal As Double 'النطاق المراد استخراج الأرقام الناقصة منه Set Rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'سطر لايجاد أقل قيمة رقمية في النطاق MinVal = Application.WorksheetFunction.Min(Rng) 'سطر لايجاد أكبر قيمة رقمية في النطاق MaxVal = Application.WorksheetFunction.Max(Rng) 'مسح محتويات النطاق الذي سيتم استخراج النتائج به Range("G2", Range("G2").End(xlDown)).ClearContents 'إنشاء متغير من النوع كائن لتخزين الأرقام الناقصة به Set Dico = CreateObject("Scripting.Dictionary") 'حلقة تكرارية لكل الأرقام المسلسلة For I = 1 To (MaxVal - MinVal + 1) 'تعتمد هذه الأسطر على إضافة الرقم الناقص إلى الكائن المخصص لذلك If Application.WorksheetFunction.CountIf(Rng, MinVal + I - 1) = Then If Not Dico.Exists(MinVal + I - 1) Then Dico.Add (MinVal + I - 1), (MinVal + I - 1) End If Next I 'رقم صف البداية للنتائج في العمود السابع B = 2 'حلقة تكرارية لوضع القيم التي تم تخزينها في النطاق المحدد For Each D In Dico.items Range("G" & B) = D B = B + 1 Next D End Sub وعشان عيون أحبابي إليكم الكود الرابع وهو أفضل الأكواد من حيث أنه لا يشترط ترتيب الأرقام وأسطر الكود سهلة الفهم وسهلة التعامل معها Sub MissingNumbers_YK_B() 'يقوم الكود باستخراج الأرقام الناقصة في تسلسل للأرقام ولا يشترط الترتيب '------------------------------------------------------------------- 'تعريف المتغيرات Dim InputRange As Range Dim X As Long, lRow As Long 'تعيين النطاق الذي سيحتوي على سلسلة الأرقام المراد استخراج الأرقام الناقصة منها Set InputRange = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'مسح محتويات النطاق الذي سيتم استخراج النتائج به Range("I2:I1000").ClearContents 'حلقة تكرارية من أقل قيمة بالنطاق لأكبر قيمة بالنطاق For X = WorksheetFunction.Min(InputRange) To WorksheetFunction.Max(InputRange) 'استخدام دالة البحث فإذا كانت القيمة المراد البحث عنها غير موجودة يعطي خطأ 'وبناءً على الخطأ يتم تنفيذ السطر التالي If IsError(Application.Match(X, InputRange, )) Then '[I] الرقم 2 هو رقم صف البداية في العمود '[I] يتم وضع الرقم الناقص في الخلية في الصف المحدد في العمود Cells(lRow + 2, "I") = X 'زيادة المتغير بمقدار واحد للانتقال لصف جديد لإدراج الأرقام الناقصة lRow = lRow + 1 End If Next X End Sub أترككم مع الملف المرفق ...للاستفادة بشكل عملي بالكود كان معكم أخوكم ياسر خليل أبو البراء YK (الموضوع مهدى للأخ الحبيب والأستاذ الكبير أسامة البراوي OB ومهدى للأخ الفاضل نايف - م) حمل الملف من هنا تقبلوا تحياتي

السلام عليكم ورحمة الله وبركاته وبعد سنين من العمل في كود الأكسس ، لازلت الى الأمس القريب كنت اعاني من عدم حصولي على النتائج المطلوبة من الجدول (بدون مجموعة محاولات) ، اذا كان المعيار هو حقل تاريخ الى ان حصلت على الكود التالي ، والذي اصبح التعامل فيه مع التاريخ سهلا انا احفظ هذه الوحدة النمطية بإسم fDateFormat: Function DateFormat(varDate As Variant) As String 'Purpose: Return a delimited string in the date format used natively by JET SQL. 'Argument: A date/time value. 'Note: Returns just the date format if the argument has no time component, ' or a date/time format if it does. 'Author: Allen Browne. allen@allenbrowne.com, June 2006. ' 'calling the Function: DateFormat(The_Date_Field) 'a = dlookup("[some field]","some table","[id]=" & me.id & " And [Date_Field]=" & DateFormat(The_Date_Field)) ' If IsDate(varDate) Then If DateValue(varDate) = varDate Then DateFormat = Format$(varDate, "\#mm\/dd\/yyyy\#") Else DateFormat = Format$(varDate, "\#mm\/dd\/yyyy hh\:nn\:ss\#") End If End If End Function وطريقة استعمال الكود كالأمثلة التالية: a = dlookup("[some field]","some table","[id]=" & me.id & " And [Date_Field]=" & DateFormat(The_Date_Field)) او ("Select DISTINCT cen, [Date] From TTTT Where [Date]=" & DateFormat(Me.Idate)) او عدة طرق اخرى اليكم مثالين في البرنامج المرفق ، كيف ان الدالة DateFormat تعطيني نتائج صحيحة مباشرة ، بينما استخدام الطريقة التقليدية للتاريخ لا تعطيني النتيجة مباشرة: الجدول يحتوي على تاريخين ، 1-5-2015 و 2-5-2015 ، وهنا سنقوم بالتجربة على التاريخ 1-5-2015 (ويمكنكم استخدام التاريخ التاثي 2-5-2015) ، وللتأكد من نتائجنا ، عملنا استعلامين : و استخدام الكود في Recordset 1. مع استعمال الدالة DateFormate Set rst = CurrentDb.OpenRecordset("Select DISTINCT cen, [Date] From tbl_T Where [Date]=" & DateFormat(Me.idate)) rst.MoveLast: rst.MoveFirst RC1 = rst.RecordCount والنتيجة صحيحة ، كما تدل عليه نتيجة الاستعلام في الاسفل: 2. مع عدم استعمال الدالة DateFromat ، وانما استخدام الطريقة التقليدية للتاريخ: Set rst = CurrentDb.OpenRecordset("Select DISTINCT cen, [Date] From tbl_T Where [Date]=#" & Me.idate & "#") rst.MoveLast: rst.MoveFirst RC2 = rst.RecordCount والنتيجة خطأ ، كما تدل عليه نتيجة الاستعلام في الاسفل: استخدام الدالة Dcount 3. مع استعمال الدالة DateFormat RC3 = DCount("*", "tbl_T", "[Date]=" & DateFormat(Me.idate)) والنتيجة صحيحة ، كما تدل عليه نتيجة الاستعلام في الاسفل: 4. مع عدم استعمال الدالة DateFormat ، ، وانما استخدام الطريقة التقليدية للتاريخ: RC4 = DCount("*", "tbl_T", "[Date]=#" & Me.idate & "#") والنتيجة خطأ ، كما تدل عليه نتيجة الاستعلام في الاسفل: جعفر 84.DateFormat_Examples.mdb.zip

الكتب هذه المعادلة في الخلية A2 واسحب نزولاً =COUNTIF($B$2:B2,B2)

الاخ نايف تم العمل كما تريد serie non reguliee.rar

السلام عليكم هذا حل معادلة صفيف لابد من ctrl+shift+enter vlookupthree ابوفاطمة.rar

السلام عليكم ارى ان هذا حل جميل ويفى بالغرض وممكن ان نضيف الاسطر التالية فى نهاية الكود لكى نحافظ على الشكل العام للشيتات الجديدة Dim I As Intger For Each SH In Worksheets If SH.Name <> "ورقة1" Then For I = 1 To 6 SH.Columns(I).ColumnWidth = Sheets("ورقة1").Columns(I).ColumnWidth Next End If Next SH

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

السلام عليكم أتفضل أخي شوف الملف المرفق وبالنسبة للأكواد في الملف الكود التالي في ThisworkBook الكود التالي يعمل على إضافة القائمة لكليك يمين في ملف الإكسل المحدد ولكي يتم الإضافة لكل ملفات الإكسل شوف الكود اللي في نهاية الرد Private Sub Workbook_Activate() Call AddToCellMenu End Sub Private Sub Workbook_Deactivate() Call DeleteFromCellMenu End Sub ثم قم بإدارج موديول عادي وانسخ فيه الكود التالي الكود يحتوي على 3 ماكرو كل واحد يعمل على تغيير حالة الحروف في باللغة الإنجليزية من حروف كبيرة إلى صغيرة إلى حسب الجملة A - a - Ali Sub AddToCellMenu() Dim ContextMenu As CommandBar Dim MySubMenu As CommandBarControl 'Delete the controls first to avoid duplicates Call DeleteFromCellMenu 'Set ContextMenu to the Cell menu Set ContextMenu = Application.CommandBars("Cell") 'Add one built-in button(Save = 3)to the cell menu ContextMenu.Controls.Add Type:=msoControlButton, ID:=3, before:=1 'Add one custom button to the Cell menu With ContextMenu.Controls.Add(Type:=msoControlButton, before:=2) .OnAction = "'" & ThisWorkbook.Name & "'!" & "ToggleCaseMacro" .FaceId = 59 .Caption = "Toggle Case Upper/Lower/Proper" .Tag = "My_Cell_Control_Tag" End With 'Add custom menu with three buttons Set MySubMenu = ContextMenu.Controls.Add(Type:=msoControlPopup, before:=3) With MySubMenu .Caption = "Case Menu" .Tag = "My_Cell_Control_Tag" With .Controls.Add(Type:=msoControlButton) .OnAction = "'" & ThisWorkbook.Name & "'!" & "UpperMacro" .FaceId = 100 .Caption = "Upper Case" End With With .Controls.Add(Type:=msoControlButton) .OnAction = "'" & ThisWorkbook.Name & "'!" & "LowerMacro" .FaceId = 91 .Caption = "Lower Case" End With With .Controls.Add(Type:=msoControlButton) .OnAction = "'" & ThisWorkbook.Name & "'!" & "ProperMacro" .FaceId = 95 .Caption = "Proper Case" End With End With 'Add seperator to the Cell menu ContextMenu.Controls(4).BeginGroup = True End Sub Sub DeleteFromCellMenu() Dim ContextMenu As CommandBar Dim ctrl As CommandBarControl 'Set ContextMenu to the Cell menu Set ContextMenu = Application.CommandBars("Cell") 'Delete custom controls with the Tag : My_Cell_Control_Tag For Each ctrl In ContextMenu.Controls If ctrl.Tag = "My_Cell_Control_Tag" Then ctrl.Delete End If Next ctrl 'Delete built-in Save button On Error Resume Next ContextMenu.FindControl(ID:=3).Delete On Error GoTo 0 End Sub Sub ToggleCaseMacro() Dim CaseRange As Range Dim CalcMode As Long Dim cell As Range On Error Resume Next Set CaseRange = Intersect(Selection, _ Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)) On Error GoTo 0 If CaseRange Is Nothing Then Exit Sub With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With For Each cell In CaseRange.Cells Select Case cell.Value Case UCase(cell.Value): cell.Value = LCase(cell.Value) Case LCase(cell.Value): cell.Value = StrConv(cell.Value, vbProperCase) Case Else: cell.Value = UCase(cell.Value) End Select Next cell With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub Sub UpperMacro() Dim CaseRange As Range Dim CalcMode As Long Dim cell As Range On Error Resume Next Set CaseRange = Intersect(Selection, _ Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)) On Error GoTo 0 If CaseRange Is Nothing Then Exit Sub With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With For Each cell In CaseRange.Cells cell.Value = UCase(cell.Value) Next cell With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub Sub LowerMacro() Dim CaseRange As Range Dim CalcMode As Long Dim cell As Range On Error Resume Next Set CaseRange = Intersect(Selection, _ Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)) On Error GoTo 0 If CaseRange Is Nothing Then Exit Sub With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With For Each cell In CaseRange.Cells cell.Value = LCase(cell.Value) Next cell With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub Sub ProperMacro() Dim CaseRange As Range Dim CalcMode As Long Dim cell As Range On Error Resume Next Set CaseRange = Intersect(Selection, _ Selection.Cells.SpecialCells(xlCellTypeConstants, xlTextValues)) On Error GoTo 0 If CaseRange Is Nothing Then Exit Sub With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With For Each cell In CaseRange.Cells cell.Value = StrConv(cell.Value, vbProperCase) Next cell With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub اذا اردت ظهور القائمة في كل ملفات الإكسل يمكنك حذف السطرين التاليين من الكود الأول Private Sub Workbook_Deactivate() Call DeleteFromCellMenu Book123.rar

الأخ الفاضل يرجى تغيير اسم الظهور للغة العربية بارك الله فيك أخي الحبيب الغالي سليم حاصبيا إثراءاً للموضوع هذا حل آخر بالأكواد .. Sub AddDataToSheets() Dim Cell As Range, Header As Range, Rng As Range, EndRng As Range Dim row As Long, NextRow As Long Dim Wks As Worksheet, SH As Worksheet Set Wks = Worksheets("ورقة1") Set Header = Wks.Range("A10:P12") Set Rng = Wks.Range("A13:M13") Set EndRng = Wks.Cells(Rows.Count, "M").End(xlUp) If EndRng.row > Rng.row Then Set Rng = Rng.Resize(EndRng.row - Rng.row + 1) Application.Calculation = xlCalculationManual Application.ScreenUpdating = False Application.DisplayAlerts = False For Each SH In Worksheets If SH.Name <> Wks.Name Then SH.Delete Next SH For row = 1 To Rng.Rows.Count Set Cell = Rng.Cells(row, "M") If Not IsEmpty(Cell) Then On Error Resume Next Set Wks = ThisWorkbook.Worksheets(Cell.Text) If Err = 9 Then Worksheets.Add After:=Worksheets(Worksheets.Count) Set Wks = ActiveSheet Wks.Name = Cell.Text Header.Copy Wks.Paste Wks.Cells(1, 1) End If NextRow = Wks.Cells(Rows.Count, "M").End(xlUp).row + 1 Rng.Rows(row).Copy Wks.Rows(NextRow) On Error GoTo 0 End If Next row Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub تقبل تحياتي Create Sheets Based On Values In Range YasserKhalil.rar

السلام عليكم إليك المرفق بعد التعديل استخدمت فكرة الاستاذ الكبير jjafferr ولكن مع تغيير بسيط استخدمت الدالة dmax بدلا من dcount لأنها برأيي تعطي دقة أكبر منها تحياتي للجميع sadra.rar

امثلة بسيطة ارجوا ان تنفعنا جميعا صيغة الدالة DLookup DLookup(expr, domain [, criteria] )‎ expr( مطلوب) اسم الحقل domain( مطلوبة) اسم الجدول/الاستعلام criteria( اختيارية) الشروط دا مثال بسيط : عازوين نعرف اسم الصنف الذي كوده 15 في جدول الاصناف اسم الجدول : items اسم الحقل الذي يحمل أرقام الاصناف : code_items اسم الحقل الذي يحمل أسماء الاصناف: items_Name كود: MsgBox DLookup("[items_Name]", "items", "code_items=15") ممكن ناخد كود الصنف من مربع نص موجود في نموذج بدلاً من التصريح في الدالة عن كود الصنف لنفترض مثلا أن مربع نص موجودٌ في النموذج باسم txtItemsCode كود: MsgBox DLookup("[items_Name]", "items", "code_items=" & Me.txtItemsCode) ممكن ناخد قيمة كود الصنف من نموذج آخر بس بشرط أن يكون مفتوحاً ، فلو كان txtItemsCode موجود في نموذج آخر باسمfrm1 فإن الكود سيأخذ الشكل التالي : كود: MsgBox DLookup("[items_Name]", "items", "code_items=" & Forms!frm1!txtItemsCode) ملحوظة بالنسبة للشروط يجب أن تأخذ في الاعتبار نوع بيانات الحقل الذي نعتمد عليه في الشرط ، في المثال السابق كان حقل نوع بياناته (رقم) ، فلو كان نوع بياناته (نص) سيكون الكود بالشكل التالي :code_items كود: MsgBox DLookup("[items_Name]", "items", "code_items='" & Me.txtItemsCode & "'") طب لو كان نوع بياناته (وقت/تاريخ) الكود هيبقى كدا كود: MsgBox DLookup("[items_Name]", "items", "code_items=#" & Me.txtItemsCode & "#") وشكر الله لكم جميعا

السلام عليكم ورحمة الله وبركاته افتقدتكم كثيرا لمعرفة ما اريده من هذا الملف قم بالتالي: قم بفتح الملف المرفق في الحالتين تمكين وتعطيل وشاهد النتيجة ثم قم بفتح الملف في حالة التمكين واضغط الزر kh_ChngPwd لتفعيل شاشة دخول باسم مستخدم وكلمة مرور ثم اغلق الملف ثم قم بفتح الملف في حالة التمكين والتعطيل وشاهد النتيجة قمت بتجربة هذا الكود على اكسل 2003و2007 وهما ما في المرفق واريدكم ان تجربوه على 2010 =================================== ممكن استخدام هذا الكود في اي ملف باستيراد الفورمين FormAhlnWShln FormChngPwd والموديل ModChngPwd ونسخ الاكواد الموجوده في حدث ThisWorkbook =================================== كلمة السر للاكواد : 1 =================================== ودمتم في حفظ الله فورم حماية الملف.rar ======================================================== من اراد استخدام الكود بدون استخدام فورم الحماية يضع هذه الاكواد في موديل Option Explicit Sub Auto_Open() kh_wVisible True End Sub Sub Auto_Close() kh_wVisible False ThisWorkbook.Close Not CBool(ThisWorkbook.Saved) End Sub Sub kh_wVisible(ibol As Boolean) Dim nBook As String nBook = ThisWorkbook.Name With Windows(nBook) If .Visible = Not ibol Then .Visible = ibol End With End Sub المرفق 2003 2007 th1.rar

السلام عليكم ورحمة الله تعالى وبركاته انا النهاردة حابب اتكلم عن دالة مهمة جدا من وجهة نظرى المتواضعة دالة من دوال التكرار دالة Do While....loop طبعا بما انى مليش فى الشرح اوى فاسمحولى اتكلم كدا بالبلدى ههههههه اول سؤال احنا بنستخدم الدالة دى امتى ؟؟؟ الاجابة اننا بنستخدم الدالة دى لما نكون عاوزين نكرر كود محدد بس اكتر من مرة ومش عارفين عدد محدد لتكرار والحدث او الكود اللى هنكرره دا هيتكرر بناء على شرط معين يعنى لو الشرط اتحقق كرر الكود وهكذا ... قشطة لحد كدا ؟؟؟ شكل الدالة دى بيبقى عامل ازاى Do While الشرط الكود Loop Do While condition code Loop يعنى ايه بقى الكلام دا المقصود ب Do While هو تنفيذ code طالما التعبير الشرطى True قشطة لحد كدا تمام ؟؟ علشان المعلومة تثبت لازم نعمل تدريب عملى هنعمل تدريب عملى بسيط جدا تعالو نشوف انا عاوز اعمل نموذج فى قلبه ليست بوكس اقوم عن طريق الدالة Do While اقوم عن طريقها بادخال الاسماء داخل الليست بوكس نفتح الاكسس ونعمل نمذج فارغ ونسميه Form1 ونعمل زر لااضافة الاسماء ونسميه Button1 ونضيف الليست بوكس ونسميها Listbox1 ايه المطلوب بقى منى ؟؟ المطلوب عن الضغط على زر Button1 يظهر صندوق InputBox لا ادخال الاسماء يبقى احنا هنستخدم دالة InputBox فى ادخال الاسماء تمام كدا يعنى لما اضغط على الزر المفروض يظهر InputBox علشان ادخل الاسم الاول ويظهر مرة تانيه علشان ادخل الاسم الثانى وهكذا لحد ما قيمة الشرط فى دالة Do While تبقى false كدا ينهى الحدث هنخلى الشرط بتاعنا هو عند ادخال كلمة انهاء يقوم بانهاء ادخال الاسماء وهنلاحظ كدا وجود حلقة تكرارية مش عارفين عدد مرات التكرار قد ايه وينتهى التكرار بمجرد ادخال كلمة " انهاء" يلا بينا على الكود طبعا دا هيتحط فى حدث عند النقر للزر 'هنفرض متغير x من نوع نص Dim x As string 'الشرط هنا بيقول انه طالما المتغير x لا يساوى انهاء كرر الكود Do while x<>"انهاء" x=InputBox("ادخال اسماء الطلاب") Me.Listbox1.AddItem (x) Loop شكرا ليكم تحياتى اخوكم مارد عارف انكم كلكم عارفين الدالة دى :mad: بس رخامة وخلا ص Do While .... Loop.rar

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله أقدم لكم اليوم موضوع ليس بجديد على الإطلاق ، ولكن أظن أن الكثيرين لا يعرفونه ، فأحببت أن أشارككم المعلومة علكم تستفيدون ، ولعلكم تنفضون غبار الكسل .. الذي طال أمده موضوعنا عن كيفية إضافة شريط أمر تحكم إلى الكليك يمين ، بمعنى آخر : عندك إجراء فرعي معين ، وبتستخدمه كثيراً ، ومش عايز الإجراء يكون مرتبط بزر أمر ولا يكون تلقائي ، لكن تريد أن يكون موجود في الكليك يمين .. إذاً فالحل بين يديك يتم وضع الكود التالي في حدث فتح المصنف Private Sub Workbook_open() 'هذا الحدث مرتبط بفتح المصنف 'يقوم الكود بإضافة سطر أمر إلى قائمة الكليك يمين 'تعريف متغير من النوع شريط أمر التحكم Dim NewControl As CommandBarControl On Error Resume Next 'حذف شريط الأمر من قائمة الكليك يمين إذا كان موجود من قبل Application.CommandBars("Cell").Controls("Show Date And Time").Delete On Error GoTo 0 'إنشاء أو إضافة شريط أمر التحكم Set NewControl = Application.CommandBars("Cell").Controls.Add With NewControl 'عنوان شريط أمر التحكم الذي سيظهر في قائمة الكليك يمين .Caption = "Show Date and Time" 'مسار واسم الإجراء الفرعي المرتبط بشريط أمر التحكم .OnAction = "Module1.DateAndTime" 'عدم فصل شريط أمر التحكم الجديد بخط .BeginGroup = False End With End Sub وحتى لا تحدث أخطاء في برنامج الإكسيل يراعى أن يتم حذف شريط أمر التحكم الذي تمت إضافته ولذا ستجد الكود التالي في حدث إغلاق المصنف Sub Workbook_BeforeClose(Cancel As Boolean) 'هذا الحدث مرتبط بإغلاق المصنف On Error Resume Next 'هذا السطر لحذف الأمر - الذي تمت إضافته عند فتح المصنف - من قائمة الكليك يمين Application.CommandBars("Cell").Controls("Show Date and Time").Delete End Sub وهذا هو الكود المرتبط تنفيذه بشريط أمر التحكم Sub DateAndTime() 'هذا هو الماكرو الذي تمت إضافته لقائمة الكليك يمين MsgBox "Today is: " & Format(Date, "dd. mm. yyyy") & "." & vbCr & vbCr & "It is: " & Format(Time, "hh:mm:ss") End Sub وأخيراً تقبلوا تحيات أخوكم أبو البراء دمتم على طاعة الله Add Control To Right Click Menu.rar

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

الحل بين يديك Classeur2 salim.rar

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

عمل ممتاز للأستاذ الفاضل / ياسرخليل وفقكم الله

السلام عليكم ورحمة الله أخي الكريم، تم تبسيط المعادلة أكثر بالتنسيق الذي تريده.... أرجو أن يفي الغرض المطلوب.... أخوك بن علية المرفق : 02_ملف_الخزينة_بالمعادلات.rar

تم تغيير اسم الظهور وفقكم الله

جزيت خيراً أخي الغالي أيمن إبراهيم على الاستجابة لطلبي والله اسمك بالعربي منور أكتر

الأخ الكريم يرجى تغيير اسم الظهور للغة العربية استبدل السطر التالي Rng.Rows(row).Copy Wks.Rows(NextRow) وضع مكانه هذين السطرين Rng.Rows(row).Copy Wks.Rows(NextRow).PasteSpecial xlPasteValues لتحصل على القيم فقط لا تنسى أن تحدد أفضل إجابة ليظهر الموضوع مجاب ومنتهي

اكثر من رائع اخي ياسر وما رأيك بعمل نفس الشيء بواسطة المعادلات ارقام ناقصة.rar

هههه . طول عمرك صاحب دم خفيف بس فعلا 2003 افيز وبيقولنا ياجماعه فيه 2007 و2010 و2013 و2016

جرب ده 02_ملف_الخزينة_بالمعادلات.rar

مشرفنا الغالي الاستــــاذ ياسر خليل طلبـــاتك أوامر تم تعديل اسم الظهر كما اقترحت ، اشكرك

جزاكم الله خيراً... روح الدعابة ...والجد في العمل ...والنتائج الصحيحة إن الكلمات لتعجز عن تصوير مشاعر الإعجاب بارك الله لك وبك وعليك أبا البراء الغالي..

السيد بن علية حاجى المعادلة التى أرفقتها هى عين المطلوب لكن بدون كلمات TAX توريد المطلوب مجرد تسلسل مجرد ترقيم وشكرا لك

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

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

استاذنا وعميد اوفيسنا . شرفنى واسعدنى مروركم كثيرا واما بخصوص هذه الرساله . فهى رساله تحذيريه تعنى ان تنسيق الملف الذى تحاول فتحه بامتداد xlt يختلف عن التسيق الاصلى للملف وهو xlsx وهى رساله امان ويمكنك تعديلها لعد ظهورها من اعدادات الامان واذا كنت واثق من الملف فاضغط yes وسيتفتح معك الملف وطبعا يمكنك بعد ذلك حفظه باى امتداد تريده تقبل منى خالص التحيه والاحترام

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

جزانا الله واياكم خيرا شرفنى مروركم

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

استدعاء بيانات الشهادات بداله اوفيست يدلاله رقم الجلوس وبها قائمه مطاطه لرقم الجلوس للمبدع ياسر خليل ووالمبدع سليم حاصبيا Offset Function.rar

تمام يا استاذ ياسر انا فعلا ما انتبهتش الى العمود المخفى وفى الحالة دى مكن يتعدل الكود الى التالى باستعمال عمود ظاهر Sub Final() Sheet7.Range("a6:ak100") = "" Application.ScreenUpdating = False x = Sheet6.[G1000].End(xlUp).Row For t = 11 To x Step 3 y = Sheet7.[A1000].End(xlUp).Row + 1 If Sheet6.Range("au" & t).Value = "له دور ثان فى" Then Sheet7.Range("a" & y) = Sheet6.Range("E" & t).Value Sheet7.Range("b" & y) = Sheet6.Range("G" & t).Value Sheet7.Range("e" & y & ":ak" & y) = Sheet6.Range("j" & t + 2 & ":ap" & t + 2).Value Else End If Next Call errase Application.ScreenUpdating = True End Sub

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

الأساتذة الكرام والأخوة الأعزاء: ياسر خليل أبو البراء مختار حسين محمود عــلي الشيــــخ بارك الله بكم وبهمتكم العالية ما أستطيع قوله فقط : ((إنكــــم متميِّـــــــــــــــــــــزون حقــــاً)).. جزاكم الله خيراً و السلام عليكم أخوكم محمد بن حسن المحمد أبو يوسف

تمام يا مستر علي .. أخيراً الحمد لله لقيت اللي يشيل عني شوية بارك الله لنا فيك وجزيت خيراً وأكلت لحم طيرٍ (كنت مفكرني هقول طيراً) ..عندي فكرة بردو باللغة العربية تقبل تحياتي

السلام عليكم مرحبا أخي اتفضل شوف الملف المرفق أنا عملت في الورقة 2 كل المطلوب ولكن في معادلة واحدة ما عليك إلا إدخال تاريخ بداية الخدمة وتاريخ انتهاء خدمة الموظف والراتب الأساسي + البدلات وسيتم إحتساب مكافاة نهاية الخدمة بناء على الشروط اللي انت موضحها المعادلة المستخدمة = IF(C2<=4,(B8*4),IF(C2<=7,(((C2-4)*(B8*1.5))+(4*B8)),IF(C2<=10,((((4*B8)+(3*B8*1.5)+((C2-7)*(B8*2))))),IF(C2<=15,(((((4*B8)+(3*B8*1.5)+(3*B8*2)+((C2-10)*(B8*2.5)))))),IF(C2>15,(((((4*B8)+(3*B8*1.5)+(3*B8*2)+(B8*5*2.5)+((C2-15)*(B8*3))))))))))) مباشرة الاموال بالكامل.rar

جزاكم الله كل خير

السلام عليكم ورحمة الله وبركاته مطلوب : البحث عن (سعر موديل) من خلال : 1- رقم الموديل 2- رقم الموسم ملاحظه : رقم الموديل مكرر وله سعر مختلف دالة v lookup بناءا على شرط.rar

أخي الفاضل جرب هذا الكود Private Sub CommandButton1_Click() On Error Resume Next x = ComboBox1.Value Sheets(x).Activate Range("A" & Range("A" & Rows.Count).End(xlUp).Row + 1).Value = TextBox1.Value Range("B" & Range("B" & Rows.Count).End(xlUp).Row + 1).Value = TextBox2.Value Range("C" & Range("C" & Rows.Count).End(xlUp).Row + 1).Value = TextBox3.Value If ComboBox1.Value = "" Then MsgBox "لم يتم تحديد ورقة العمل" End If TextBox1.Value = "" TextBox2.Value = "" TextBox3.Value = "" TextBox1.SetFocus End Sub

وعليكم السلام أخي عبدالله انا في اعتقادي Dcount أفضل ، لهذه الاسباب: 1. لسنا بحاجة الى الامر NZ لأول رقم ، 2. اذا لأي سبب تم حذف سجل في منتصف السجلات ، فـ Dmax سيعطيك الرقم الاكبر التالي ، مما يعني انك لن تعرف ان هناك رقم ناقص/تم حذفه من المنتصف ، ويصبح التسلسل غير صحيح (إلا اذا كان هذا غير مهم ، فهنا Dmax أفضل) ، بينما في Dcount ، فممكن معرفة اذا تم حذف سجل بسهولة ، حيث ان الرقم الاخير الموجود سوف يتكرر (طبعا هذا سيطلب تدخل المبرمج لحل هذه النقطة) ، ونستطيع ان نعمل كود للتأكد بأن الرقم غير متكرر ، مما سيعطينا اشعار بذلك ، 3. Dmax يقرأ بيان الحقل ، بينما Dcount يحسب السجلات ، لهذا Dcount اسرع في التنفيذ ولكن في نهاية الامر ، كل الطرق تؤدي الى روما ، والخيار للذي ترتاح له جعفر

أخي الفاضل المنار لم تستجب لمطلبي ..عموماً قمت بالعمل على ورقة عمل واحدة فقط ليطمئن قلبك أن الأمر ممكن .. قمت بالتغيير قليلا في ملف الـ Template الذي يعتبر بمثابة النموذج المراد العمل عليه إليك الملف التالي .. ويمكنك الإضافة إلى الكود بحيث يشمل أي بيانات .. اكتفيت بورقة العمل الأولي فقط Sub SplitWB() Dim WBK As Workbook Dim Cell As Range Dim strPath As String Dim I As Long, Arr Application.ScreenUpdating = False Application.DisplayAlerts = False Arr = ThisWorkbook.Sheets("Sheet1").Cells(1).CurrentRegion.Value For I = 2 To UBound(Arr, 1) strPath = ThisWorkbook.Path & "\" FileCopy strPath & "Template.xlsx", strPath & Arr(I, 2) & ".xlsx" Set WBK = Workbooks.Open(strPath & Arr(I, 2) & ".xlsx") With WBK With .Sheets("المعلومات الاساسية") ThisWorkbook.Activate .Range("B3").Resize(15, 1) = Application.Transpose(Array(ThisWorkbook.Sheets("Sheet1").Range(Cells(I, 2), Cells(I, 16)))) .Range("A19") = Arr(I, 17) .Range("A21") = Arr(I, 18) .Range("A23") = Arr(I, 19) End With .Close SaveChanges:=True End With Next I Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox "تم بحمد الله .. قل سبحان الله وبحمده سبحان الله العظيم", vbInformation End Sub تقبل تحياتي Copy Workbook Template & Name It By Employee YasserKhalil.rar

تم معالجة الامر بدون كود فقط بواسطة المعادلات وهي (مطاطة يمكنك اضافة او تغيير البيانات) probl salim.rar

وعليكم السلام في النموذج ، في الحدث "بعد تحديث" الحقل نوع الصادرة ، استعمل هذا الكود: Me.seq = DCount("[typ]", "sadr", "[year1]=" & Year(Now())) + 1 جعفر

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

السلام عليكم ورحمة الله وبركاته جرب المعادلة التالية =VLOOKUP(A1;INDIRECT(B1&"!"&"A1:C15");3;FALSE) اذا لم يتحقق المطلوب ارفق ملف كمثال لتوضيح طلبك

لعمل تصفيه أو تنقيه على جزء صغير من بين جمله فى خليه نحن جميعاً أصبحنا نعرف عملية التنقيه أو التصفيه بأن نضغط على السهم الموجه إلى الأسفل ثم نختار منه ما نريد من بين ما يظهر من القائمه ولكننا سنتعرف هذه المره على تنقية جزء صغير من بين جمل متشابهه ولتكن هذه الأسماء : حسام أبو العز حامد محمد طه حسام السيد أبو العلا حاتم الهوارى حامد نبيه حميد سالم حازم عبدالعزيز ما أريد أن أوضحه هو : كيف لنا أن ننتقى بكل إسم فيه " حــا " من بين الأسماء المذكوره أعلاه أى نريد إستخراج الأسماء حامد .... حاتم .... حازم .... لأنهم مشتركون فى الحرفين ((( حا ))) وذلك عن طريق الإختيار DATA ثم FILTER ثم AUTO FILTER عندئذٍ سيظهر لك سهم التنقيه إفتحــــه إختر CUSTOM سيظهر لك مربع حوارى به إختيارات تأكد من وجود الإختيار أو الشرط يساوى أو equals فى الخانه المقابله ضع علامة النجمه أولاً * ثم الكلمه التى تريد تنقيتها من بين الجمله ولتكن حا ثم * أى ستكون هكذا * حا * إضغط Enter ستجد أنه تمت عملية التنقيه لكل الأسماء التى بها حا فقط السر هنا يكمن فى العلامه " * " لأن وجودها فى أول الكلمه أو آخرها معناه تحديد هذا الجزء فقط وبهذه العلامه تخبر الإكسيل بتجاهل باقى الأحرف والكلمات الموجوده فى الخليه أرجو أن أكون قد أضفت جديداً أحمد عبدالعزيز