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

بعد اذن أ/ خالد : ممكن فكرة الحل تعتمد على القيام بحساب مربعات النص داخل النموذج المحتوية فقط على القيم الرقمية أو التي تبدأ بحروف معينة وطبعا الحساب من حيث القيمة والعدد وتقسمهم على بعض قبل فتح التقرير ضع مربع نص مثلا اسمه avtext داخل النموذج وقبل فتح التقرير مباشرة ضع الكود Dim ctl As Control Dim C, v As Integer For Each ctl In Me.Controls If ctl.ControlType = acTextBox Then ' check text box only If ctl.name Like "m*" Then ' check if text box name start with m If Nz(ctl.Value, "") <> "" Then ' check if text box not empty v = v + ctl.Value ' value counter C = C + 1 ' number counter End If End If End If Next ctl avtext = v / C

جرب هذا الكود Private Sub CommandButton1_Click() Sheets("انسولين الهيئة").Activate '============================================== Dim i As Integer, j As Integer, x, y lrow = Range("c" & Rows.Count).End(xlUp).Row + 1 If lrow < 5 Then lrow = 5 If lrow > 27 Then MsgBox "انتقل للبيان التالى": Exit Sub x = 4: y = 3 With Sheets("انسولين الهيئة") .Range("C5:J27").ClearContents For i = 1 To 144 .Cells(x, y) = Val(Me.Controls("TextBox" & i)) y = y + 1 If y = 11 Then y = 3: x = x + 1 Next End With End Sub

الطريقة التي وضعها استاذنا الفاضل ابو تراب صحيح واكثر احترافية واليك طريقة اخرى في نموذج الدخول وضعنا مربع نص مخفي اسمه tx2 وجعل قيمته تساوي يمكن الاستغناء عن الحقل المخفي ووضع كود في نموذج Employees يغني عن الحقل ولكن هذه الطريقة اعتقد انها اسهل Me.tx2 = cboUserName.Column(1) في نموذج Employees الحقل نص0 جعلنا قيمته تساوي [Forms]![Login]![tx2] ولاضافة اسم المستخدم للجدولCard_print للحقل user وضعنا في حدث بعد التحديث للحقل emp_id او لاي حقل اخر Me.user = Me.نص0 الملف مرفق ShowUser.accdb

مثال2.accdb

تفضل آسف لم انتبه الى التنسيق و المحتوى في المشاركة الاولى Sub AddWorksheetsR() Dim raedSheet As Worksheet Dim Source As Range Dim c As Range Set raedSheet = ActiveSheet Set Source = ActiveSheet.Range("a2:a100") Application.ScreenUpdating = False For Each c In Source RName = Trim(c.Text) If Len(RName) > 0 Then Worksheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = RName Sheets("home").Range("a:i").Copy ActiveSheet.Range("a:i").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False ActiveSheet.Range("a:i").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False End If Next c raedSheet.Activate Application.ScreenUpdating = True End Sub New Microsoft Excel Worksheet.xlsm

وعليكم السلام ورحمة الله وبركاته المشكلة ان لديك عناصر اسماء عربي اولاً قم باعادة تسمية جميع العناصر في جميع النماذج باسماء لاتينية ( انجليزية ) ثانياً قم بانشاء قاعدة بيانات جديدة واستورد اليها جميع الكائنات ( جداول - استعلامات - نماذج ... الخ ) تحياتي

Try This Macro Sub Button02() ActiveSheet.Shapes.Range(Array("مستطيل 1")).Select If Selection.Text = "إخفاء الصفوف" Then Rows("5:20").EntireRow.Hidden = True With Selection .Font.ColorIndex = 2 .Text = "إظهار الصفوف" .ShapeRange.Fill.ForeColor.RGB = _ RGB(255, 0, 0) End With Else Rows("5:20").EntireRow.Hidden = False With Selection .Font.ColorIndex = 3 .Text = "إخفاء الصفوف" .ShapeRange.Fill.ForeColor.RGB = _ RGB(209, 255, 0) End With End If [A1].Select End Sub

جرب هذا الملف Compaire.xls

جرب هذا الملف (تم تصميم اليوزر يحيث انه يمكنك التنقل داخل الصفحة حتى ولو كان اليوزر ظاهراً) لتعدبل البيانات: 1- اكتب الأسم الذي تريد تعديله (Salim) مثلاً 2- أملأ باقي البيانات 3- اضغط على زر تعديل (تظهر لك رسالة تسالك عن الاسم الجديد) مثلاً (Officena) 4-اضغط على Ok 5-اذا كان Salim موجوداً في العامود الثاني يقوم الماكرو بتغييره الى Officena مع بياناته الجديده My_data by_User form.xlsm

فقط بدّل الأسماء في الصفحات (داخل الكود) اي اجعل Targ هي ورقة القيود Source هي ورقة1

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

تفضل يمكنك استخدام هذه المعادلة وبكده يكون انتهى الموضوع =IF(C10<=$D$8,((C10*10%))*15%,IF(C10>=$D$8,((C10-$D$8)*15%+($D$8*10%))*55%,"")) ومبارك الترقية الى عضــو ممــيز وسننتظر مشاركاتك الإيجابية ان شاء الله فى مساعدة جميع الأعضاء احتساب المعادلة.xlsx

أي معادلة جربت؟

وبارك فيك أخي الكريم وفي الاستاذ خالد وتقبل منكم صالح الاعمال لكن لي استفسار بسيط : لماذا التكرار في هذه الاسطر ؟ حيث أرى أنها متشابهة تمامافإن كانت كذلك فيمكنك وضعها مرة واحدة في دالة ثم تقوم باستدعائها Me.a1.Caption = "100" Me.s1.Caption = "50" Me.a2.Caption = "100" Me.s2.Caption = "50" Me.a3.Caption = "100" Me.s3.Caption = "50" Me.a4.Caption = "100" Me.s4.Caption = "50" Me.a5.Caption = "100" Me.s5.Caption = "50" Me.a6.Caption = "100" Me.s6.Caption = "50" Me.a7.Caption = "100" Me.s7.Caption = "50" Me.a8.Caption = "100" Me.s8.Caption = "50" Me.a9.Caption = "100" Me.s9.Caption = "50" Me.a10.Caption = "100" Me.s10.Caption = "50" Me.a11.Caption = "100" Me.s11.Caption = "50"

سلمت أناملكما ^_^

ولإثراء الموضوع فهذا كود من اعمال الأستاذ الكبير سليم حاصبيا له منا كل المحبة والإحترام Option Explicit Sub creat_shett() Dim i%, t, m% Dim x%: x = Application.CountA(Sheets("اسماء الصفحات").Range("A:A")) + 1 For i = 3 To x t = Sheets("اسماء الصفحات").Range("a" & i) On Error Resume Next m = Len(Sheets(t).Name) On Error GoTo 0 If m = 0 Then '===========================================================' Sheets("Home").Copy After:=Sheets(Sheets.Count) With ActiveSheet .Name = Sheets("اسماء الصفحات").Range("a" & i) .Range("a1") = .Name End With '===========================================================' End If m = 0 Next Sheets("اسماء الصفحات").Select End Sub Sheets List.xlsm

تفضل =IF(C10<=$D$8;((C10*10%))*15%;IF(C10>=$D$8;((C10*15%)-($D$8*10%))*55%;"")) الضريبة.xlsx

شكرا استاذنا الفاضل استاذ سليم وجزاك الله خيرا ونفعنا بعلمك تم المطلوب بحمد الله وجزاك الله خيرا

يمكنك استخدام هذا الكود لذلك Sub SelectPrintArea() Dim PrintThis As Range ActiveSheet.PageSetup.PrintArea = "" Set PrintThis = Application.InputBox _ (Prompt:="Select the Print Range", Title:="Select", Type:=8) PrintThis.Select Selection.Name = "NewPrint" ActiveSheet.PageSetup.PrintArea = "NewPrint" ActiveSheet.PrintOut End Sub Print.xls

اخي ارفق مثال

في الخلية K4 هذه المعادلة (وليس C4+E4+G4+I4) =SUM(C4,E4,G4,I4) واسحب نزولاً و كذلك في الخلية L4 =SUM(D4,F4,H4,J4) لأن الدلة SUM تعتبر النص(أو الفراغ) صفراً ولا تحتسبه

اخي الكريم تفضل هذا الملف شبيه الى حد ما لطلبك عليك الكتابة وسيتغير تلقائيا ولكن عليك دراسة الكود والتطبيق حتى يمكنك التغيير بناء على احتياجاتك color.xlsm

جرب هذا الملف (الصفحة Target_sh ) الكود Option Explicit Sub Get_data() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim D As Worksheet, T As Worksheet Dim D_Rg As Range, T_rg As Range, Single_rg As Range Dim RoD%, RoT%, All_ro%, X%, y% Dim Nme$ Set D = Sheets("Data"): Set T = Sheets("Target_sh") Set D_Rg = D.Range("A4").CurrentRegion Set T_rg = T.Range("A3").CurrentRegion RoT = T_rg.Rows.Count If RoT > 1 Then _ T_rg.Offset(1).Resize(RoT - 1).Clear If D.FilterMode Then D_Rg.AutoFilter RoD = D_Rg.Rows.Count Set Single_rg = D_Rg.Offset(1).Resize(RoD - 1) Nme = T.Cells(3, "K") D_Rg.AutoFilter 4, Nme D_Rg.AutoFilter 3, "اجل" y = D_Rg.SpecialCells(12).Rows.Count If y > 0 Then Single_rg.Columns(2).SpecialCells(12).Copy T.Range("A4").PasteSpecial (12) Single_rg.Columns(8).SpecialCells(12).Copy T.Range("B4").PasteSpecial (12) End If D_Rg.AutoFilter D_Rg.AutoFilter 4, Nme D_Rg.AutoFilter 3, "نقدا" X = D_Rg.SpecialCells(12).Rows.Count If X = 0 Then Exit Sub Single_rg.Columns(2).SpecialCells(12).Copy T.Range("C4").PasteSpecial (12) Single_rg.Columns(8).SpecialCells(12).Copy T.Range("D4").PasteSpecial (12) All_ro = T.Range("A3").CurrentRegion.Rows.Count With T.Cells(All_ro + 3, 1) .Value = "المجموع:" .Offset(, 1) = Evaluate("=SUM(B4:B" & All_ro + 2 & ")") .Offset(, 2) = "المجموع:" .Offset(, 3) = Evaluate("=SUM(D4:D" & All_ro + 2 & ")") End With With T.Cells(4, 1).Resize(All_ro, 4) .InsertIndent 1: .Borders.LineStyle = 1 .Font.Size = 13: .Font.Bold = True .Interior.ColorIndex = 38 End With If D.FilterMode Then D_Rg.AutoFilter With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الملف مرفق Mabieat_Filter.xlsm

تفضل يمكنك فقط استخدام هذا الكود ...وانا لا ارى اى اهمية او وجود اصلاً لهذا الفورم Sub OneCell() Sheets("Sheet1").Range("B4:B100").Value = Sheets("Sheet1").Range("A4:A100").Value End Sub تواتي6.xlsm

هلا اخي جرب هذا الكود DoCmd.TransferDatabase acExport, "Microsoft Access", CurrentProject.Path & "\TESTDB_BACKUP.accdb", acTable, "TABLE1", "TABLE1" مرفق مثال بالتوفيق TEST.zip

فقط عليك استخدام هذه المعادلة =IFERROR(INDEX($A:$A,MATCH($E4,$B:$B,0)),"") aa.xls

بارك الله فيك اخي ابو تراب هذا هو المطلوب

هل هذا المطلوب اخي TEST5.accdb

بالفعل ترجمة الكلمة الدارجة تختلف بحسب سوق العمل من مجتمع لآخر ، فهي تختلف بحسب البلد و أيضا بحسب المهنة أو الصناعة و قبل ما أضيف رأيي الحالي بعد قراءة ما سبق من ردود و مراجعة نتيجة التصويت، فضلا عن عدة مناقشات جانبية ، سأورد بعد المصادر للاطلاع ويليها رأيي الحالي: 👈 اولا بعض المصادر: ترجمة جوجل ، تتفق مع التصويت بأن ترجمة organisation هي منظمة ، و لها بدائل مثل تنظيم او جمعية أو تجمع .... من هنا قاموس المعاني قدم عدة ترجمات منها منظمة ومؤسسة و تنظيم و قد اورد منظمة فى الامثلة التي تتفق مع كونها منظمات دولة او انسانية او عربية و استخدم كلمة مؤسسة فى الأمثلة التى تتعلق بالجهات الاخرى مثل الشركات والجهات الحكومية ... من هنا بحسب النسخة العربية من وكيبديا ، و التي لا تعد مصدرا موثوقا للترجمة السليمة، و لكنها قد تعبر أحيانا عن الترجمة الدارجة ، فالتعريف الوارد هو : " المنظمة مجموعة من الأفراد لهم هدف معين، يستخدمون طريقا أو أكثر للوصول اليه. فمثلا هناك منظمات إنسانية، منظمات بيئية، منظمات عمالية، الخ..." من هنا و هذه الأمثلة تتفق مع رأيي الشخصي وهذا لا يتفق بالكامل مع وصف organisation فى النسخة الانجليزية من نفس الموقع من هنا و التي ظهرت كما يلي : " An organization or organisation is an entity, such as a company, an institution, or an association, comprising one or more people and having a particular purpose. 👈 ثانيا ما أره حتى اللحظة (وأنا بالطبع منفتح لتعديل هذا الرأي) : انا ممن لا يستسيغون ترجمة Organization أو Organisation بمنظمة ، و ان كانت هي الترجمة الحرفية السليمة و ما ورد عليه رأي الأغلبية و أجد غضاضة كبيرة فى استخدام الكلمة خارج وصف المنظمات الدولية العربية أو الإنسانية، سواء كانت حكومية أو شبه حكومية أو خاصة. بالنسبة لي استخدام منظمة كترجمة دارجة تعبر عن كيانات من ما يشمها التعبير بالانجليزية مثل شركة أو مؤسسة أو منشأة غير مستساغ و مازلت احاول قبوله بصعوبة بالغة لانه حاز على أغلبية الآراء. أرفض ترجمة Organisation كمؤسسة ، و أري الترجمة المناسبة لكلمة مؤسسة هي Enterprise و لا اراها تناسبة الكيانات الصغيرة أما منشأة فأرى ترجمتها Establishment ، و كيان ترجمتها Body الاقرب الي وجهة نظري بين الخيارات المطروحة هو خيار الجهة و الجهات ، و أراه الأعم و الأشمل و الأوسع قبولا. و لكن من الواضح كما ذكرت أن ذلك لا يمكن تعميمه فهناك مجتمعات تستسيغ و تستخدم كلمة منظمة، و يبدو أنهم فى نفس الوقت لا يتفقون معي على أن استخدام كلمة الجهات ملائما، و الدليل انها حازت المرتبة الثالثة فى التصويت بعد منظمة و مؤسسة. 👈الخلاصة أنني أدعم كلمة جهة / جهات كترجمة شاملة ل Organization / Organizations اذا كان علينا اختيار كلمة واحدة ، و أرها تصلح لوصف الجهات الحكومية و الخاصة و المنظمات و كل ما يندرج تحت التعريف. أما اذا كان التنوع بحسب السياق متاحا فقد يؤدي ذلك لصياغة أفضل يصحبها و سيصحبها خلاف أكبر 😇 ومازال الموضوع مفتوح للنقاش

يقصد الاستاذ جعفر بالمثال هو ان تضع مرفقا مصغرا تظهر المشكلة فيه ويمكن التعديل عليه

وعليكم السلام بالطبع لا يمكن عمل هذا الا بدالة معرفة Option Explicit Function Lookup_concat(Search_string As String, _ Search_in_col As Range, Return_val_col As Range) Dim i As Long Dim result As String For i = 1 To Search_in_col.Count If Search_in_col.Cells(i, 1) = Search_string Then result = result & "," & Return_val_col.Cells(i, 1).Value End If Next Lookup_concat = Trim(result) End Function ووضع هذه المعادلة بداية من الخلية H3 سحباً للأسفل =Lookup_concat($G3,$A$2:$A$700,$B$2:$B$700) Test1.xlsm

تفضل لك ما طلبت بعد اذن الأستاذ الرائد اخر عملية وعدد الشهور1.xlsx

تفضل هذه الفيديوهات ستساعدك فى القضاء عليه https://www.youtube.com/watch?v=TJadvSU4KKc https://www.youtube.com/watch?v=Cxcg3hXlE1A

هلا يمكنك تسجيل المستخدم الحالي في متغير تبع TempVars مثال 'خزن المستخدم الحالي TempVars("CurrentUser") = cboLoginUser.value 'اعرض المستخدم الحالي lblCurrentUSer.Caption = TempVars("CurrentUser") بالتوفيق

وعليكم السلام-لك ما طلبت سجل المدرسة2020.xls

وعليكم السلام -على الرغم انك لم تقم برفع ملف موضح فيه كل المطلوب الا انك يمكنك استخدام هذا Public Function XLookup(ByVal vTable As Variant, _ ByVal vResult As Variant, _ ParamArray vKeyVals() As Variant) As Variant Const cRoutine As String = "XLookup" Dim oLo As ListObject 'Table containing data Dim vKeys As Variant 'vKeyVals internal version Dim sCol As String 'Column Address Range to search Dim vKey As Variant 'Key(s) to find in Column(s) Dim lKey As Long 'Current key Dim lRow As Long 'Found Row Dim lCol As Long 'Found Column Dim sAddTxt As String 'Additional Error Text ' Error Handling Initialization On Error GoTo ErrHandler Set XLookup = Nothing ' Check Inputs and Requisites ' Table Select Case TypeName(vTable) Case Is = "ListObject": Set oLo = vTable Case Is = "Range": Set oLo = vTable.ListObject Case Else: Set oLo = ActiveSheet.Evaluate(vTable).ListObject End Select ' Return Column If TypeName(vResult) = "Range" Then vResult = vResult.Value2 ' Search Keys If UBound(vKeyVals) = -1 Then Err.Raise DspError, , "#Key(s) required" ' When called by VBA, ParamArrays sometimes are stuffed in the first element If IsArray(vKeyVals(LBound(vKeyVals))) Then _ vKeys = vKeyVals(LBound(vKeyVals)) Else _ vKeys = vKeyVals ' Procedure With oLo If Not .DataBodyRange Is Nothing Then ' Just 1 key - Use Worksheet.Function because it is fastest w/1 Key If LBound(vKeys) = UBound(vKeys) Then vKey = vKeys(UBound(vKeys)) If IsNumeric(vKey) Then vKey = CDbl(vKey) lRow = Application.WorksheetFunction.Match( _ vKey, _ .ListColumns(1).DataBodyRange, _ 0) ' More than 1 key - Use Worksheet.Evaluation because it is fastest w/multiple keys Else ' Concatenate Key Values and Search Column Addresses For lKey = LBound(vKeys) To UBound(vKeys) lCol = lCol + 1 sCol = IIf(sCol <> vbNullString, sCol & " & ", vbNullString) & _ .ListColumns(lCol).DataBodyRange.Address ' Determine Key Value If TypeName(vKeys(lKey)) = "Range" Then _ vKey = vKey & vKeys(lKey).Value2 Else _ If IsDate(vKeys(lKey)) Then _ vKey = vKey & CLng(vKeys(lKey)) Else _ vKey = vKey & vKeys(lKey) Next ' Find Row # by Evaluating MATCH within the Table's worksheet lRow = .Parent.Evaluate("=Match(""" & vKey & """," & sCol & ",0)") End If ' Get Column # lCol = .ListColumns(vResult).Index ' Return result Set XLookup = .ListRows(lRow).Range(lCol) End If End With ErrHandler: If Err.Number > 0 Then ' Create sAddTxt (Additional Error Text) if needed Select Case Err.Number Case Is = 9: sAddTxt = "Column " & vResult & " not found in " & oLo.Name Case Is = 13, 1004: sAddTxt = "Key(s) " & Join(vKeys, ",") & " not found" Case Is = 424: sAddTxt = "Table not found" End Select ' Customize Errors based on UDF of VBA caller If TypeName(Application.Caller) = "Range" Then 'Called from UDF MLookup = CVErr(xlErrRef) Debug.Print cRoutine & ":" & Err.Description & vbLf & sAddTxt Else 'Called from VBA (most likely) Select Case Err.Number Case Is = 13, 1004: 'Key(s) not found. Log Error Debug.Print cRoutine & Err.Description & vbLf & sAddTxt Case Else: 'Pop Up Error Message Select Case DspErrMsg(cModule & "." & cRoutine, sAddTxt) Case Is = vbAbort: Stop: Resume 'Debug mode - Trace Case Is = vbRetry: Resume 'Try again Case Is = vbIgnore: 'End routine End Select End Select End If End If End Function أو يمكنك مشاهدة هذا الرابط Custom Excel XLOOKUP Function أو هذا الرابط UDF: XLOOKUP – Using VLOOKUP for left AND right searches وهذا ايضا فيديو للشرح https://www.youtube.com/watch?v=Tbqh4_HcUlI

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

جرب هذا طبعا بعد اذن الأستاذ الرائد , فممكن ان تكون هذه مشكلة من عندك فملف الأستاذ الرائد يعمل بكفاءة عموماً -تفضل تم التعديل على نفس اكوادك شششششش1.xlsm

أحسنت استاذ منير عمل ممتاز وشرح وافى وكافى

اجعل تنسيق الخلايا هكذا [$-2000000]0

بارك الله فيك استاذنا الكريم وجزاك الله كل خير

غير ممكن. و الله أعلم. حتى لو وضعت الكود يمكن التغيير فيه بتعطيل الماكرو من قائمة خيرات مكروسوفت اوفيس و فتحه . و اذا كان الملف على جهازك ممكن تثبت هذا البرامج و لا يمكن لأي أحد أن ينسخ الملفات التي تحددها. و الله أعلم . M File Anti-Copy https://raymondcc.r.worldssl.net/M File Anti-Copy 4.0-1622.zip

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

تفضلوا قائمة منسدلة بدون أعمدة مساعدة وبدون الاستعانة بورقة العمل ، ومنقحة وبلا فراغات وبها قيم فريدة أي غير مكررة وعلاوة على كل ما سبق مرتبة أيجدياً.. إليكم الملف المرفق Unique Sorted Validation List.rar