عبدالله باقشير

السلام عليكم كود الحذف يحذف 1377 دائرة سريعا وتم عمل تنسيق شرطي مشابه لعمل الكود بمعادلة واحدة لجميع الخلايا =AND(ISNUMBER(Q$9);$B10>0;OR(Q10<Q$9;Q10="غ";Q10="غـ")) وتم تضبيط كود الترحيل للناجحين ودور ثاني Sub KH_Start() On Error Resume Next Dim M As Integer, N As Integer, X As Integer, R As Integer Sheet5.Range("A10:CX1000").Clear Sheet7.Range("A10:CX1000").Clear M = 10 ' اول صف لورقة الناجحين N = 10 ' اول صف لورقة دور ثان Application.ScreenUpdating = False With Sheet1 X = .Range("A" & .Rows.Count).End(xlUp).Row For R = 10 To X If .Range("CX" & R) = "ناجح" Then .Range("A" & R).Resize(1, 102).Copy KH_Paste Sheet7, M M = M + 1 End If If .Range("CX" & R) = "دور ثان" Then .Range("A" & R).Resize(1, 102).Copy KH_Paste Sheet5, N N = N + 1 End If Next R End With Application.ScreenUpdating = True MsgBox "تم ترحيل " & M - 10 & " طالب ناجح" & Chr(10) & Chr(10) & "تم ترحيل " & N - 10 & " طالب دور ثاني", vbMsgBoxRight, "الحمدلله" End Sub Sub KH_Paste(MySheet As Worksheet, KRow As Integer) On Error Resume Next With MySheet .Range("A" & KRow).PasteSpecial xlPasteValues .Range("A" & KRow).PasteSpecial xlPasteFormats .Range("A" & KRow) = KRow - 9 End With Application.CutCopyMode = False End Sub تفضل المرفق ________________________________1.rar

السلام عليكم الاخ قصي اسم الورقة غير صحيح Sub اضافة_حذف() On Error Resume Next Dim XX As Shape Set XX = ActiveSheet.Shapes("الدائرة") With XX.TextFrame.Characters If .Text = "اضافة الدوائر" Then Circles1 .Text = "حذف الدوائر" Else RemoveCircles1 .Text = "اضافة الدوائر" End If End With On Error GoTo 0 End Sub

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

السلام عليكم الاخ/ ابن النيل------حفظه الله الملف المرفق لا يوجد فيه الكود الذي قمنا بالتعديل عليه

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

السلام عليكم بكود التصفية المتقدمة: Sub KH_START() On Error Resume Next Dim X As Integer Dim MyRag As Range Application.ScreenUpdating = False With Sheet1 X = .Range("A" & .Rows.Count).End(xlUp).Row Set MyRag = .Range("A9:CB" & X) End With '================================= ' الناجحين MyRag.AdvancedFilter Action:=xlFilterCopy _ , CriteriaRange:=Sheet2.Range("CC1:CC2") _ , CopyToRange:=Sheet2.Range("A9:CB9"), Unique:=False '================================= ' الراسبين MyRag.AdvancedFilter Action:=xlFilterCopy _ , CriteriaRange:=Sheet3.Range("CC1:CC2") _ , CopyToRange:=Sheet3.Range("A9:CB9"), Unique:=False '================================= ' مسار اخر MyRag.AdvancedFilter Action:=xlFilterCopy _ , CriteriaRange:=Sheet4.Range("CC1:CC2") _ , CopyToRange:=Sheet4.Range("A9:CB9"), Unique:=False '================================= Application.ScreenUpdating = True On Error GoTo 0 End Sub تفضل المرفق aysam_1.rar

السلام عليكم كل الازرار ترتبط بكود واحد في الملف المفتوح وهونفس الكود في جميع الملفات الموجودة في المجلد (Roushdy) عمل الكود: يقوم الكود بحفظ الملف المفتوح واغلاقه وفتح الملف الذي اسمه موجود على الزر الذي قمت بالضغط عليه الكود: Sub OpenFill() On Error Resume Next Dim Mybook_close As Workbook Dim MyFile As String Dim Mybook As String Set Mybook_close = ActiveWorkbook Mybook_close.Save Mybook = ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text MyFile = ActiveWorkbook.Path & "\" & Mybook Application.ScreenUpdating = False Application.DisplayAlerts = False Workbooks.Open MyFile Mybook_close.Close Application.DisplayAlerts = True Application.ScreenUpdating = True On Error GoTo 0 End Sub تفضل المرفق Roushdy.rar

السلام عليكم الاخ الفاضل/ جلال حفظه الله هناك شرط لازم يكون عمود رقم الجلوس اكبر من الصفر اذا لا تريده بامكانك الاستغناء عنه بحذف او تجميد هذه الجزئية من الكود If Cells(C.Row, G) = 0 Then GoTo 1 ودمتم

السلام عليكم اخي الفاضل / احمد ----------حفظه الله ولك بمثل دعائك اضعاف مضاعفة اكرمك الله اخي الفاضل / mhareek ----------حفظه الله وقفت عاجزا عن الرد على هذا الكلام ودمعت العين اكرمك الله وحفظك في الدارين اخي الفاضل / boss----------حفظه الله نعم المسلم للمسلم تقبل تحياتي وشكري ودمتم في حفظ الله ورعايته

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

السلام عليكم يوخذ اسم الملف من الزر نفسه Sub openfill() On Error Resume Next Dim MyFile As String Dim Mybook As String Mybook = ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Text MyFile = ActiveWorkbook.Path & "\" & Mybook Application.ScreenUpdating = False Application.DisplayAlerts = False Workbooks.Open MyFile Application.ScreenUpdating = True Application.DisplayAlerts = True On Error GoTo 0 End Sub تفضل المرفق Roushdy.rar

السلام عليكم الاخ الفاضل/ أ.وهبي----------------حفظه الله الاخ الفاضل/ جلال----------------حفظه الله تقبلا تحياتي وشكري ============= الاخ الفاضل/قصي----------------حفظه الله مارايك لو يظهر فورم فيه بار متحرك اثناء الحذف لترى ذلك و ينطوي الوقت سريعا

السلام عليكم الاخ الاستاذ الفاضل/ amhateb-------------حفظه الله الاخ الفاضل/ خالد القس----------------حفظه الله تقبلا تحياتي وشكري ============= الاخ الفاضل/ أ.وهبي----------------حفظه الله غير الجزئية التالية من الكود: Set V = ActiveSheet.Shapes.AddShape(msoShapeOval, C.Left + 3, C.Top + 3, C.Width - 6, C.Height - 6) يمكنك تغيير الارقام لموضع الدائرة وعرضها و طولها بالنسبة للخلية حسب ما يناسبك تقبل تحياتي وشكري ============= الاخ الفاضل/ قصي----------------حفظه الله ساحاول زيادة السرعة و لكن هل لاحظت ان اغلب الخلايا في هذا الملف فارغة مما ادى الى زيادة عدد الدوائر في الواقع العملي تقريبا كم من الدوائر قد توضع (عدد تقريبي) تقبل تحياتي وشكري

شرح ممتاز اخي يحي حفظك ربي و

السلام عليكم اخي الفاضل اسمي خبور وليس خابور ----للمصدر /خبر-اخبار خبور خير --------- خبر حلو -------خبر سار فهمت المعنى وهو هرج باللهجة العمانية

السلام عليكم اخي الفاضل ثلاثين ملف ما شاء الله طيب حيكونوا مفتوحين والا مغلقين؟؟؟ ==================== العمود L : في هذا العمود للتاريخ الواحد نسختين نسخة مكتوبة ونسخة كارتباط (هجري) صح ؟! والله مش عارف اقول لك ايه انا عايز اساعدك ولكن المعطيات والمطلوبات صعبة شوية

السلام عليكم تفضل الرابط: http://www.officena.net/ib/index.php?showtopic=28601

السلام عليكم نريد المساعدة ولكن ملفك لا يفتح عندنا وعند الكثير

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

السلام عليكم الاخ الحبيب / نزار----------------حفظه الله الاخ الحبيب / الجزيرة----------------حفظه الله تقبلا تحياتي وشكري ================================ الاخ الحبيب الاستاذ/ محمدي ----------------حفظه الله غير هذه الجزئية من الكود اللي فيها الشرط If (IsNumeric(Cells(R, C.Column)) And C.Value < Cells(R, C.Column)) Or C.Value = "غ" Or C.Value = "غـ" Then بهذه الجزئية: If IsNumeric(Cells(R, C.Column)) And Not IsEmpty(Cells(R, C.Column)) And (C.Value < Cells(R, C.Column) Or C.Value = "غ" Or C.Value = "غـ") Then تقبل تحياتي وشكري ودمتم في حفظ الله

عمل رائع جدا جدا سلمت يداك و

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

السلام عليكم الاخ الفاضل/ J2006 -------حفظه الله لقد قمت بدمج الطلب الاخير خاصتك في هذا الموضوع هو عبارة عن اسم نطاق قمنا باضافته لنطاق البيانات في الورقة الاولى ورقة1!$B$5:$L$26 انظر الى الصور ادناه بامكانك تعديل النطاق حسب الصفوف التي تريدها بدون اضافة اعمدة اخرى ===================== وهذا الطلب الاخير خاصتك بدون استخدام اسم نطاق قم بتحديد النطاق الذي تريده في هذه الجزئية من الكود '===================================== ' هنا يمكنك تحديد نطاق البيانات Set MyCell = ورقة1.Range("B5:L61") '===================================== تفضل المرفق ______.rar =============================== الاخ الفاضل/ جمال الفار -------حفظه الله تقبل تحياتي وشكري ودمتم في حفظ الله .

السلام عليكم الاخ الفاضل / ياسر خليل---------------حفظه الله شكرا جزيلا على الكلام الطيب عملنا الطلب بطريقة اخرى التصفية المتقدمة بالكود مع اضافة ما طلبت من الفرز والحدود فقد قمت به في الملف السابق مع شرح مبسط للكود Sub KH_START() On Error Resume Next Dim R As Integer, X As Integer Application.ScreenUpdating = False '================================= ' مسح البيانات KH_ClearContents '================================= ' فرز School KH_Sort '================================= ' تصفية الذكور Range("معيار").Range("C2") = "ذكر" Range("School").AdvancedFilter Action:=xlFilterCopy _ , CriteriaRange:=Range("معيار") _ , CopyToRange:=Range("الفصل").Columns("B:D"), Unique:=False '================================= ' تصفية الاناث Range("معيار").Range("C2") = "أنثى" Range("School").AdvancedFilter Action:=xlFilterCopy _ , CriteriaRange:=Range("معيار") _ , CopyToRange:=Range("الفصل").Columns("F:H"), Unique:=False '================================= Range("معيار").Range("C2").ClearContents '================================= ' ترقيم البيانات With Range("الفصل") For R = 2 To .Rows.Count If .Cells(R, 2) <> "" Then .Cells(R, 1) = .Cells(R, 2).Row - 2 If .Cells(R, 6) <> "" Then .Cells(R, 5) = .Cells(R, 6).Row - 2 Next R End With '================================= 'تسطير الصفوف المحتوية على البيانات X = Range(Range("A1").CurrentRegion.Address).Rows.Count With Range("A3:H" & X) .Borders.LineStyle = 1 End With '================================= Application.ScreenUpdating = True Range("A3").Select On Error GoTo 0 End Sub ودمتم في حفظ الله School_Record_2009_1.rar