الخالدي

السلام عليكم ورحمة الله وبركاته ايضا في المرفق يمكن من قائمة الماوس - الامر(ملفات العمل) الانتقال الى ملف ثم الا نتقال الى ورقة في أمان الله الإنتقال الى ورقة مختارة-ماوس3.rar

السلام عليكم ورحمة الله وبركاته في المرفق من قائمة الزر الايمن للماوس انقر على (اوراق العمل...) ثم اختار ورقة من القائمة وعذرا ان كان المرفق خارج عن طلب صاحب الموضوع في أمان الله الإنتقال الى ورقة مختارة-ماوس2.rar

السلام عليكم ورحمة الله وبركاته ولإثراء الموضوع من قائمة الزر الايمن للماوس انقر على (الانتقال الى ورقة...) ثم ادخل اسم الورقة في أمان الله الإنتقال الى ورقة مختارة-ماوس1.rar

السلام عليكم ورحمة الله وبركاته جرب المرفق اضافة سطر2.rar

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

السلام عليكم ورحمة الله وبركاته جرب الكود المرفق اضافة سطر1.rar

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

السلام عليكم ورحمة الله وبركاته كالعادة كود متميز اخي الفاضل / أبو حنين وبعد اذن اخي الفاضل / عبدالله المجرب هنا محاولة لكود اخر في حدث الورقة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 And Target.Row > 9 Then On Error GoTo 10 If Target = "" Then Exit Sub If Len(Target) < 12 Then GoTo 10 If Len(Target) > 14 Then GoTo 10 If Asc(Mid(Target, 1, 1)) < 65 Then GoTo 10 If Asc(Mid(Target, 1, 1)) > 90 Then GoTo 10 If Asc(Mid(Target, 2, 1)) < 65 Then GoTo 10 If Asc(Mid(Target, 2, 1)) > 90 Then GoTo 10 If Asc(Mid(Target, 3, 1)) < 65 Then GoTo 10 If Asc(Mid(Target, 3, 1)) > 90 Then GoTo 10 If Mid(Target, 4, 7) * 1 > 0 Then GoTo 10 If Mid(Target, 11, 1) <> "/" Then GoTo 10 If Mid(Target, 12, 3) * 1 < 1 Then GoTo 10 GoTo 20 10 Target = "" MsgBox "ادخال غير صحيح" 20 End If في أمان الله

السلام عليكم ورحمة الله وبركاته اخي العزيز / فضل لتنويع الحلول جرب المرفق حيث تم اضافة جدول وخلايا مساعدة لتصغير حجم المعادلة في أمان الله المعادلة المطلوبة2.rar

السلام عليكم ورحمة الله وبركاته جزاك الله خيرا اخي الفاضل ابراهيم ارجوا ان يكون الحل المرفق مقبول او ربما يتفضل احد الاخوة بحل افضل في أمان الله حذف البيانات2.rar

وعليكم السلام ورحمة الله وبركاته جزاك الله كل خير اخي الفاضل أبو أنس ولك مثل دعائك لي زادك الله من فضله واعادك الينا سالما

السلام عليكم ورحمة الله وبركاته جزيت خيرا اخي عبدالله اخي ابراهيم حسب فهمي للمطلوب جرب الكود التالي Sub AL_KHALEDI() Dim Rng As Range Set Rng = Sheets("Sheet1").AutoFilter.Range Set Rng = Range(Rng.Rows(2), Rng.Rows(Rng.Rows.Count)) Set Rng = Rng.SpecialCells(xlCellTypeVisible) Set Rng = Rng.SpecialCells(xlCellTypeConstants, 23) Rng.ClearContents End Sub في أمان الله

السلام عليكم ورحمة الله وبركاته اخي الكريم شكرا وبارك الله لك جرب الكود المرفق الكود يقوم بالترحيل الى ورقة الشهر بعد مسح محتوياتها وفي حال عدم وجود ورقة للشهر يتم عمل ورقة جديدة يتم تسمية الورقة حسب الشهر في الفلتر الكود يقوم بترحيل العمود الاول والثالث من الفلتر في امأن الله Book4.rar

السلام عليكم ورحمة الله وبركاته أيضا كود اخر وهو مقتبس من كود أخي الفاضل / رجب يعمل الكود في حالة وجود فلتر في الورقة مع إظهار رسالة تنبيه في حال كانت بيانات الفلتر غير مصفاة Dim newsheet As Worksheet Dim rng As Range Dim sh As Worksheet Set rng = ActiveSheet.AutoFilter.Range If Not ActiveSheet.AutoFilterMode Then MsgBox "لا يوجد فلتر في الورقة": Exit Sub If Not ActiveSheet.FilterMode Then M = MsgBox("بيانات الفلتر غير مصفاة" + vbCr + "هل ترغب في المتابعة على اي حال" & "", 4 + 32 + 524288 + 1048576, "تنبية") If M = vbNo Then Exit Sub End If Set rng = ActiveSheet.AutoFilter.Range x = [f1].Value If x = "" Then MsgBox "الخلية فارغة اكتب اسم الشيت أولا ": Exit Sub On Error GoTo Error: If Sheets(x).Name = x Then MsgBox "هذا الاسم موجود من قبل", vbOKOnly, "اسم شيت مكرر": Exit Sub Error: Set newsheet = Sheets.Add newsheet.Name = x rng.Copy newsheet.Range(rng.Cells(1).Address)[/size] [size=4] في امأن الله Book3.rar

السلام عليكم ورحمة الله فكرة اكثر من رائعة اخي الفاضل رجب خالص الود

السلام عليكم ورحمة الله وبركاته الأستاذ الفاضل / عبدالله المجرب شكرا على الثناء الطيب ونسال الله لكم دوام التميز علما وخلقا الأخ الفاضل / فضل شكرا على الإطراء لأخونك وأما عن مشكلة المعادلات فلا اعلم السبب جرب الملف المرفق بعد تعديل المعادلات , والمعادلة تحتوي على جزء معرف باسم xxx في امأن الله نسخ البيانات المفلترة بالمعادلات2.rar

السلام عليكم ورحمة الله وبركاته بارك الله في الأخوة الكرام ولإثراء الموضوع الكود التالي يقوم بنسخ الفلتر بصرف النظر عن موقعة في الورقة Sheets("Sheet1").AutoFilter.Range.Copy Sheets("Sheet2").Range("A1") في الملف المرفق حل باستخدام المعادلات نسخ البيانات المفلترة بالمعادلات.rar

السلام عليكم ورحمة الله وبركاته جرب المرفق في امأن الله MINUTE3.rar

أخي الفاضل / العيدروس أخي الفاضل/ رجب مبارك لكما الترقية المستحقة تمنياتي لكم بدوام التوفيق

السلام عليكم ورحمة الله وبركاته اخي فضل أحبك الله الذي أحببتني له وشكرا على الثناء الطيب وبالنسبة لشرح Range("A2:F5" & Range("A10000").End(xlUp).Row).ClearContents السطر فيه خطاء مني فالصحيح A2:F بدلا من A2:F5 واعتقد ان الامر واضح الان بعد التصحيح , والأمر طبعا خاص بمسح خلايا النطاق حتى اخر خلية غير فارغة ايضا ارجوا تصحيح السطر For r = 1 To Sheets("Sheet1").Range("A10000").End(xlUp).Row بتصحيح الرقم 1 بالرقم 2 واعتذر عن الأخطاء بسبب الاستعجال خوفا من انقطاع الكهرباء اُعيد تصحيح الكود المعروض في المشاركة السابقة والحل بالمعادلات في اقرب فرصة ان شاء الله واكيد سيكون هناك إثراء للموضوع من اخوة المنتدى في امأن الله

السلام عليكم جرب الكود Sub AL_KHALEDI() Array1 = Array("A", "B", "C", "D", "E", "F") Array2 = Array("B", "D", "G", "H", "I", "J") Range("A2:F" & Range("A10000").End(xlUp).Row).ClearContents s = 1 For r = 2 To Sheets("Sheet1").Range("A10000").End(xlUp).Row x = 0 x = x + Application.CountIf(Sheets("Sheet1").Cells(r, "C"), [I2]) x = x + Application.CountIf(Sheets("Sheet1").Cells(r, "D"), [J2]) x = x + Application.CountIf(Sheets("Sheet1").Cells(r, "J"), [K2]) If x = 3 Then s = s + 1 For A = 0 To 5 Cells(s, Array1(A)).Value = Sheets("Sheet1").Cells(r, Array2(A)).Value Next A End If Next r End Sub الترحيل بناء على ثلاث شروط1.rar

السلام عليكم ورحمة الله وبركاته شكرا اخي فضل على المرور الكريم واعتذر عن تاخر ردي على الموضوع بسبب انقطاعات الكهرباء في مدينتي ReDim vA(Range(b).Columns.Count) وجدت مثل هذا السطر في بعض الاكواد ولا علم لي بتفاصيل كثيرة عنه وربما احد الخبراء يعطينا توضيح اكثر واعتقد انه إعلان عن صفيف من المتغيرات باسم vA وعدد المتغيرات في هذا الصفيف مرتبطة بعدد الاعمدة في النطاق والسطر أستخدم في الكود لغرض تخزين رقم صف تعبئة الخلايا بحيث يكون كل متغير خاص بعمود محدد وللإشارة إلى احد المتغيرات في الصفيف نكتب اسم الصفيف ثم قوسين ونضع بين القوسين رقم يمثل منزلة او رتبة المتغير في الصفيف vA(r) = vA(r) + 1 السطر هنا يقوم بزيادة 1 الى القيمة السابقة للمتغير حيث r يمثل موقع المتغير في الصفيف علما انه يمكن الاعلان عن صفيف يحتوي متغيرات وموزعة على صفوف وأعمدة وبخصوص For Each فالأولي تختص بارجاع قيم خلايا العمود F3:I248 الثانية تقوم بمقارنتها بالخلايا أعلى النطاق F3:I248 حيث (Range(b).Rows(0).Columns) هو(F2:I2) ثم إرجاع رقم العمود في حال التطابق ردي على عجل ارجوا المعذرة في امان الله

اخي الكريم تم اضافة التلوين الى الكود Sub AL_KHALEDI() a = "D3:D248" b = "F3:I248" Application.ScreenUpdating = False Range(b).ClearContents Range(a & "," & Range(a).Offset(0, -1).Address).Interior.ColorIndex = 0 ReDim vA(Range(b).Columns.Count) Dim cl_a As Range, cl_b As Range For Each cl_a In Range(a) For Each cl_b In Range(b).Rows(0).Columns If cl_b = cl_a Then r = cl_b.Column - Range(b).Column + 1 vA(r) = vA(r) + 1 Range(b).Rows(vA(r)).Columns(r).Value = cl_a.Offset(0, -1).Value l = 36 - r Mod 56 + 1 Range(b).Rows(vA(r)).Columns(r).Interior.ColorIndex = l cl_a.Offset(0, -1).Interior.ColorIndex = l Exit For End If Next cl_b Next cl_a Application.ScreenUpdating = True End Sub[/size] [size=4] اما بخصوص بقية طلبك فليس لدي وقت لعمله ربما احد الاخوة يساعدك موقف3.rar

إضافة إلى حل الفاضل رجب حل اخر بالكود Sub AL_KHALEDI() a = "F3:I248": b = "D3:D248" Range(a).ClearContents ReDim vA(Range(a).Columns.Count + Range(a).Column) Dim cl_b As Range, cl_a As Range For Each cl_b In Range(b): For Each cl_a In Range(a).Rows(0).Columns If cl_a = cl_b Then vA(cl_a.Column) = vA(cl_a.Column) + 1 cl_a.Offset(vA(cl_a.Column), 0).Value = cl_b.Offset(0, -1).Value Exit For End If Next cl_a: Next cl_b End Sub في أمان الله موقف2.rar

انا لله وإنا اليه راجعون اللهم اغفر له وارحمه وأدخله فسيح جناتك وألهم أهله الصبر والسلوان