عبدالله المجرب

السلام عليكم اخي الفاضل المطلوب غير مفهوم ما المقصود ب

ما فهمت اخي احمد

تم تعديل العنوان للدلالة

الاخ الفاضل جرب هذا الكود Sub Abu_Ahmed() LR = [E1000].End(xlUp).Row For i = LR To 2 Step -1 If Cells(i, 5) = Empty Then Rows(i).Delete Shift:=xlUp End If Next End Sub

السلام عليكم اخي الفاضل سختفي الاوراق وبعد اختيار الورقة الرئيسية التي تريد ستظهر الاوراق جرب الكود بعد التعديل Sub GO_TO() On Error Resume Next For i = 4 To Sheets.Count Sheets(i).Visible = 2 Next Application.CommandBars("Workbook Tabs").Controls("More Sheets...").Execute If Err.Number > 0 Then Err.Clear Application.CommandBars("Workbook Tabs").ShowPopup End If On Error GoTo 0 For i = 4 To Sheets.Count Sheets(i).Visible = -1 Next End Sub

السلام عليكم اخي فضل جرب هذا الكود (ضعه في زر أمر) Sub Abu_Ahmed() On Error Resume Next Application.ScreenUpdating = False w = 7 For Each cl In [B2:B23] If cl = [N3] And cl.Offset(0, 1) = [N4] Then MyArr = MyArr & Trim(cl.Offset(0, -1)) & "," End If Next If MyArr = Empty Then GoTo 1 For Each c In Split(Mid(MyArr, 1, Len(MyArr) - 1), ",") Cells(w, 11) = c Cells(w, 12) = [N3] Cells(w, 13) = [N4] Cells(w, 14) = Application.VLookup(c, [A2:D23], 4, 0) w = w + 1 Next LR = [K1000].End(xlUp).Row Range(Cells(6, "K"), Cells(LR, "N")).Sort Key1:=Cells(6, "N"), Order1:=xlDescending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal If LR < 10 Then LR = 10 Range("K10:N" & LR).ClearContents 1: Application.ScreenUpdating = True End Sub

السلام عليكم يمكنك اخي الفاضل حماية محرر الاكواد برقم سري شاهد الصورة

السلام عليكم اعتقد ان افضل طريقة هي طريقة الاستاذ ابواسامة

بالنسبة الى الرسالة التحذيرية ضلل هذا العمود ثم من التحقق من الصحة اختر اي قيمة === بالنسبة لباقي الطلبات امهلني وقت فهذه الايام منشغل بشدة فعذرني

اللهم أمين === احترافية حتى في اكواد الفلترة سلمت يمينك يا ابا علي

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

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

السلام عليكم شاهد هذه الروابط http://www.officena.net/ib/index.php?showtopic=33549 http://www.officena.net/ib/index.php?showtopic=10213 وهناك الكثير فقط قم بالبحث باستخدام كلمة باركود

ممكن تخفي الصف عند الطباعة

السلام عليكم اخي الفاضل هذه الجزئية هي لتحديد واختيار الثوابت (من ارقام وبيانات) فقط دون باقي العناصر مثل المعادلات والكائنات والتنسيقات وغيرها ليتم تطبيق اي امر علها وحدها وهنا تم تطبيق امر المسح === جرب هذه الخطوات في شيت به قيم ومعادلات اضغط F5 ثم خاص ثم الصيغ ثم موافق ولاحظ ما يحدث

دالة مميزة بتميزكم يا ابا علي

السلام عليكم جرب هذا التعديل لتجاوز خطاء عدم وجود بيانات Sub Button1_Click() prompt = "هل حقا تريد مسح البيانات ؟.انتبه لا يوجد تراجع عن المسح!!" Command_buttons = vbYesNo + VbMsgBoxRt1Reading Title = "تحذير. انتبه" project = MsgBox(prompt, Command_buttons, Title) If project = vbYes Then Range("A7:Z100").Select On Error GoTo 1 Selection.SpecialCells(xlCellTypeConstants, 23).Select Selection.ClearContents 1: Range("A1").Select End If End Sub ======== بخصوص الطلب الثاني كيف ينضغط عندك مرتين وفيه رسالة تنبيهية انا جربت ولكنه لا يمسح المعادلات

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

السلام عليكم اخي ابو نصار حل ممتاز جداً ولي ملاحظة ارى لو ان كود عمل القائمة في حدث تفعيل ورقة العمل التي بها القائمة المنسدلة لكان افضل حتى تصبح القائمة المنسدلة مرنة لو اضيفت شيتات جديدة Private Sub Worksheet_Activate() For Each sh In ActiveWorkbook.Worksheets S_ALI = S_ALI & "," & sh.Name Next sh Range("A1").Select With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=S_ALI End With End Sub

السلام عليكم جرب المرفق فيه قائمة منسدلة متغيرة بأسماء الشيتات وعند اختيار شيت يتم الانتقال اليه في الخلية D4 في الورقة 1 == قائمة منسدلة بأسماء الشيتات.rar

السلام عليكم احذف عمود الاسم2 وعمود المرجع

جرب هذا الكود ضعه في حدث الورقة بحث Private Sub Worksheet_Change(ByVal Target As Range) Dim cl As Range n = 1 If Not Intersect(Target, [E2]) Is Nothing Then Set MyRng = Sheets("بيانات").[B2:B72] [B5:I22].ClearContents For Each cl In MyRng If cl.Value = Target.Value Then cl.Resize(1, 6).Copy Cells([C22].End(xlUp).Row + 1, 2) = n Cells([C22].End(xlUp).Row + 1, 3).PasteSpecial Paste:=xlPasteValues n = n + 1 End If Next Application.CutCopyMode = False [A1].Select End If End Sub

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

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