رجب جاويش

أخى الفاضل عمل data validation ليس الزاميا لكى تعمل المعادلة ولكنه فقط لضمان ادخال المقاس صحيح بدون الخطأ الذى تسبب فى عدم عمل الدالة وهذا السبب هو عدم تطابق المقاس المكتوب مع المقاس الموجود فى صفحة ( sheet4 ) حيث تجد أن المقاس 100x100 بعده مسافة زائدة تسبب عم التطابق فيظهر الخطأ فى المعادلة وهذا شكل المقاس مع وجود المسافة " 100×100" والمفروض أن يكون هكذا "100×100"

أخى الفاضل المعادلة تعمل جيدا ولضمان ذلك يفضل عمل data validation لخانة المقاس واختيار List ثم تضع المعدلة =size بذلك تعمل المعادلة بدون أى مشاكل واليك المرفق مثال على ذلك دوال لا تعمل .rar

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

تفضل أخى تم تظبيط المعادلة والكود يعمل بشكل جيد دوال لا تعمل .rar

أخى الحبيب / حمادة عمر دائما أفكارك مبتكرة وتوظف الأفكار بطريقة جميلة بجد تسلم ايديك

أخى الحبيب / أبو محمود أخى الحبيب / عباس السماوي أخى الحبيب / حمادة عمر أختى الفاضلة / أم عبد الله جزاكم الله كل خير جميعا هذه فعلا هى أخلاق الأسرة الواحدة ( أسرة أوفيسنا )

أخى الفاضل / أبو محمد أشرف جزاك الله كل خير على النشاط والجهد المميز

أخى الحبيب / أبو محمود إنما هى زيادة فى الخير أخى الحبيب فلا داعى للأسف فلا يوجد أسف بين الأخوة المتحابين فى الله

ويمكن ضم المعادلتين معا =OR(C3:H3="A";AM3:DH3="A")

ولجعل التنسيق على أكثر من مدى تكون معادلات التنسيق كالآتى =OR(C3:H3="A") =OR(AM3:DH3="A")

السلام عليكم أفضل تحية لإخوتى الأعزاء أبو محمود وعباس السماوى وللمشاركة مع الأحبة يمكن التنسيق الشرطى من خلال المعادلة البسيطة =OR(C3:AG3="A") تنسيق شرطي1.rar

أستاذى الحبيب / عبد الله باقشير جزاك الله كل خير

أستاذى الحبيب / عبد الله باقشير أدامك الله للمنتدى ولنا مبدعا ومعلما

السلام عليكم تسلم ايديك أخى الحبيب / أبو محمود ولاثراء الموضوع هذا كود لتنفيذ المطلوب Sub ragab() Dim ws As Worksheet Set ws = Sheets("data") LR = ws.Cells(Rows.Count, 2).End(xlUp).Row '============================================ [A4:H1000].ClearContents For i = 4 To LR If ws.Cells(i, 2) = [C1] Then ws.Cells(i, 1).Resize(1, 8).Copy Range("A" & [A1000].End(xlUp).Row + 1).PasteSpecial xlPasteValues End If Application.CutCopyMode = False Next Set ws = Nothing End Sub استدعاء1.rar

مليار مليار مبروك للأستاذ / ابو محمد اشرف

أخى الحبيب / أبو حنين عذرا لعدم رؤيتى عهذا العمل الرائع الا متأخرا لانشغالى فى الفترة السابقة بعض الشئ وأسمح لى أن أحييك أجمل وأرق تحية على لمساتك السحرية

أخى وصديقى الحبيب / أحمد البحيرى نورت المنتدى كله والله وحشتنا ابداعاتك فى الاكسل جزاك الله كل خير وربنا يوفقك فى جميع أمور حياتك

الأستاذ الفاضل / مجدى يونس لعبة جميلة ورائعة جزاك الله كل خير وكل التحية للأمورة سما ولأخى الحبيب أبو سما ( حمادة عمر )

ولاثراء الموضوع هذا تعديل آخر Sub ragab3() Dim LR As Integer Dim LR1 As Integer Set WS = Sheets("57") Set WS1 = Sheets("58") LR = WS.Cells(Rows.Count, 1).End(xlUp).Row LR1 = WS1.Cells(Rows.Count, 1).End(xlUp).Row For Each cll In WS1.Range("A10:A" & LR1) For Each cl In WS.Range("A5:A" & LR) If cl = cll Then Sheets("58").Cells(cll.Row, 2).Value = cl.Offset(0, 1).Value Sheets("58").Cells(cll.Row, 3).Value = cl.Offset(0, 2).Value Sheets("58").Cells(cll.Row, 4).Value = cl.Offset(0, 3).Value End If Next Next End Sub

أخى ابراهيم فعلا الكود يبدو كما هو دون تغير ولكن كان الاختلاف بسيط جدا جدا وهو كما أوضح أخى أحمد عبد الناصر فى مشاركته الكلمة cll فى السطرين التاليين كانت غير متماثلة For Each cll In WS1.Range("A10:A" & LR1) If cl = cll Then حيث كانت احداهما تنتهى بحرف L والأخرى تنتهى برقم 1

بعد اذن أخى أحمد عبد الناصر ولتكملة بقية البيانات تفضل أخى ابراهيم Sub ragab3() 'كود استخراج بيانات Dim LR As Integer Dim LR1 As Integer Set WS = Sheets("57") Set WS1 = Sheets("58") LR = WS.Cells(Rows.Count, 1).End(xlUp).Row LR1 = WS1.Cells(Rows.Count, 1).End(xlUp).Row x = 10 For Each cl In WS.Range("A5:A" & LR) For Each cll In WS1.Range("A10:A" & LR1) If cl = cll Then Sheets("58").Cells(x, 2).Value = cl.Offset(0, 1).Value Sheets("58").Cells(x, 3).Value = cl.Offset(0, 2).Value Sheets("58").Cells(x, 4).Value = cl.Offset(0, 3).Value x = x + 1 End If Next Next End Sub

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

السلام عليكم تأكيدا على ما تفضل به أخى الفاضل الشهابى هذه صورة لما تقصد فعلا عند الضغط على عبارة صفحة 1 من 318 ( العدد الحالى ) تظهر لك نافذه صغيرة تكتب فيها رقم الصفحة المراد الانتقال اليها ثم تضغط اذهب كما فى الصورة الموضحة

أخى وليد تم دمج الأكواد المطلوبة وتكون بهذا الشكل Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim strDate As String, DefPath As String Dim FileNameZip, FileNameXls Dim oApp As Object Sheets("main screen").Activate For I = 2 To Sheets.Count Sheets(I).Unprotect (1234) Next If ActiveWorkbook Is Nothing Then Exit Sub DefPath = ActiveWorkbook.Path If Len(DefPath) = 0 Then MsgBox "Plz Save activeworkbook before zipping" & Space(12), vbInformation, "zipping" Exit Sub End If If Right(DefPath, 1) <> "\" Then DefPath = DefPath & "\" End If strDate = Format(Now, " dd-mmm-yy h-mm-ss") FileNameZip = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".zip" FileNameXls = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".xls" If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then ActiveWorkbook.SaveCopyAs FileNameXls newzip (FileNameZip) Set oApp = CreateObject("Shell.Application") oApp.Namespace(FileNameZip).CopyHere FileNameXls On Error Resume Next Do Until oApp.Namespace(FileNameZip).items.Count = 1 Application.Wait (Now + TimeValue("0:00:01")) Loop On Error GoTo 0 Kill FileNameXls MsgBox "completed zipped : " & vbNewLine & FileNameZip, vbInformation, "zipping" Else MsgBox "FileNameZip or/and FileNameXls exist", vbInformation, "zipping" End If End Sub Private Sub Workbook_Open() Sheets("MyDate").Range("E3:IT3").ClearContents For I = 2 To Sheets.Count Sheets("MyDate").Cells(3, I + 3) = Sheets(I).Name Next 'UserForm1.Show End Sub Private Sub newzip(sPath) If Len(Dir(sPath)) > 0 Then Kill sPath Open sPath For Output As #1 Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0) Close #1 End Sub

أخى الفاضل / وليد أرسل الكود الثانى أو أرفق الملف ربما يمكن دمج الكودين فى كود واحد