محمد هشام.

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

وعليكم السلام ورحمة الله تعالى وبركاته اليك حل بديل بالاكواد اول خطوة قم بتسمية نطاق عمود التصنيف بالشكل التالي =OFFSET(التعريف!$E$3;;;COUNTA(التعريف!$E:$E)-1) 2) وقم باظافة عنصر Combobox في اول خلية للقائمة المنسدلة G3 3) ضع هدا الكود في حدث شيت صفحة الادخال Dim F(), MH, Rng Private Sub ComboBox1_Change() Dim MH() MH = Application.Transpose([liste]) Me.ComboBox1.List = MH If Me.ComboBox1.ListIndex = -1 And IsError(Application.Match(Me.ComboBox1, MH, 0)) Then Me.ComboBox1.List = Filter(MH, Me.ComboBox1.Text, True, vbTextCompare) Me.ComboBox1.DropDown End If ActiveCell.Value = Me.ComboBox1 If ComboBox1.Value <> "" Then ComboBox1.BackColor = RGB(255, 255, 255) Else ComboBox1.BackColor = &HFFFF00 End If End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim lr As Long Dim sh1 As Worksheet: Set sh1 = Worksheets("صفحة الادخال") Dim sh2 As Worksheet: Set sh2 = Worksheets("التعريف") lr = sh1.Range("A" & Rows.Count).End(xlUp).Row Set wsdata = Range("G3:G" & lr) If Not Intersect(wsdata, Target) Is Nothing And Target.Count = 1 Then If MH <> "" Then If IsError(Application.Match(Range(MH), F, 0)) Then Range(MH) = "" F = Application.Transpose(sh2.Range("Liste")) Me.ComboBox1.Height = Target.Height + 4 Me.ComboBox1.Width = Target.Width Me.ComboBox1.Top = Target.Top Me.ComboBox1.Left = Target.Left Me.ComboBox1 = Target Me.ComboBox1.Visible = True Me.ComboBox1.Activate MH = Target.Address Else Me.ComboBox1.Visible = False End If End Sub Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Set Rng = ActiveCell If KeyCode = 13 Then If IsError(Application.Match(Rng, F, 0)) Then Rng = "" Rng.Offset(1).Select End If End Sub Private Sub ComboBox1_DropButtonClick() lr = Worksheets("التعريف").Cells(Rows.Count, 5).End(xlUp).Row ComboBox1.List = Sheet2.Range("E2:E" & lr).Value End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then ComboBox1.Value = "" End If End Sub 3) دوبل كليك على combobox وابحث باي حرف في اي مكان في السطر . حركة الصندوق.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاستاد @محمد حسن المحمد Private Sub Workbook_Open() MyPassword = ("123") For Each Worksheet In ActiveWorkbook.Worksheets Worksheet.protect Password:=MyPassword, DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True Next End Sub ما الخطأ في هذا الكود.xlsm

بارك الله فيك اخي نظيم =IF(C2="";"0";C2-SUM(C3:C7)-SUM(C9:C11)) التجربة 1 (1) (1).xlsx

حل اخر ادا لم يكن عندك مانع في طريقة ترتيب التوزيع Sub Dis_numbers() Dim rng As Range Dim rng2 As Range Dim cell As Range 'الخلايا المستهدفة Set rng = Range("I3,F3,C3,N12") For Each cell In rng Set rng2 = Range(cell.Offset(1, -1), cell.Offset(4, -1)) rng2.Value = Int(cell.Value / 5) cell.Offset(0, -1).Value = cell.Value - Application.WorksheetFunction.Sum(rng2) Next cell End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''حدث ورقة 1''''''''''''''''''' Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'Row Number If Target.Row = 3 Then Exit Sub Select Case Target.Column 'Columns Case 3, 6, 9 Call Dis_numbers End Select ' Cell N12 'Column ("N") If Target.Row = 12 Then Exit Sub Select Case Target.Column Case 14 Call Dis_numbers End Select End Sub توزيع رقم 3.xlsb

Sub Sheets_Arrays1() Dim temp As Variant Dim arr As Variant Dim F As Boolean Dim ws As Variant Dim WSdata As Worksheet: Set WSdata = Sheets("Total") For Each ws In Sheets(Array("1", "2", "3")) temp = ws.Range("k5:N" & ws.Cells(Rows.Count, 11).End(xlUp).Row).Value If F Then arr = ArrayJoin(arr, temp) Else arr = temp F = True End If Next ws With Sheets("Total") .Range("C4").Resize(1, 4).Value = Array("م", "الاسم", "الرقم الوظيفي", "سعد") .Range("C5").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr End With End Sub '''''''''''''''''''ترحيل البيانات في اخر صف فارغ''''''''''''''''''''''' Sub Sheets_Arrays2() Dim F&, j& Dim ws As Variant Dim WSdata As Worksheet: Set WSdata = Sheets("Total") WSdata.Range("C4").Resize(1, 4).Value = Array("م", "الاسم", "الرقم الوظيفي", "سعد") For Each ws In Sheets(Array("1", "2", "3")) F = ws.Cells(Rows.Count, "K").End(xlUp).Row j = WSdata.Cells(Rows.Count, "C").End(xlUp).Row Application.ScreenUpdating = False ws.Range("K5:N" & F).Copy Destination:=WSdata.Range("C" & j + 1) Application.ScreenUpdating = True Next ws End Sub ترحيل من عدة صفحات V3.xlsm

ممكن توضيح ما هي طريقة البحث المطلوبة

https://streamable.com/md5m4x

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

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

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

ناجح v2.xlsx

تقصد بشرط عدد السنوات ..يمكنك تغيير المعادلة بهدا الشكل =INDEX($I$3:$M$6; MATCH(C2;$H$3:$H$6;0); MATCH(B2; $I$2:$M$2; 0)) ملف v3.xlsx

=IF($D$6="";"";IF($D$6="غ";"غ";IF($D$6>=50;"ناجح";IF($D$6<50;"له برنامج علاجي";"")))) ناجح v2.xlsx

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

تفضل اخي سعد حاولت قدر الامكان تنفيد المطلوب لاكن بطريقة مختلفة اتمنى ان تستفيد منها مع بعض الاظافات البسيطة في انتظار الرد بعد التجربة sella v4.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته ادا كنت قد فهمت طلبك بشكل صحيح =INDEX($I$3:$I$6;MATCH(C2;$H$3:$H$6);1) v2 ملف.xlsx

تمام ابشر اخي سعد ساحاول تنفيد المطلوب ان شاء الله

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

تفضل اخي بالتوفيق..... دوائر v3.xls

تفضل اخي Option Explicit Sub selectasheet() If Not SheetExists("" & Sheets("basic").Range("b2").Value) Then MsgBox "ورقة العمل غير موجودة!" Else Sheets("" & Sheets("basic").Range("b2").Value).Select End If End Sub Function SheetExists(SheetName As String) As Boolean SheetExists = False On Error GoTo NoSuchSheet If Len(Sheets(SheetName).Name) > 0 Then SheetExists = True Exit Function End If NoSuchSheet: End Function المساعدة.xlsm

تفضل اخي Function circle1(dr As Range) Dim OvName As String OvName = "oval" + dr.AddressLocal MrH = 0.3 * dr.Height MrW = 0.2 * dr.Width OvalW = dr.Width - MrW OvalH = dr.Height - MrH Set shShape = dr.Worksheet.Shapes.AddShape(msoShapeOval, dr.Left + MrW / 2, dr.Top + MrH / 2, OvalW, OvalH) With shShape .Name = OvName .Fill.Visible = msoTrue .Line.Weight = False .Fill.ForeColor.RGB = RGB(255, 255, 0) End With End Function دوائر v2.xls

تفضل جرب دوائر.xls

اخي هده مسالة اخرى ليس لها علاقة بالقوائم ولم نشتغل عليها من قبل على العموم تفضل اخي Dynamic Orders - Pivot_V11.xlsm

اخي اولا هل النطاق المرحل ثابث يعني 15 صف ثانيا هل تقصد عند كل ترحيل ان تكون البيانات المرحلة دائما في مابين راس الصفحة وزيلها ثالثا هل الاوراق ستكون تحت بعضها