طارق محمود

السلام عليكم أخي العزيز جرب الكود التالي في حدث الورقة bd2 ممكن تغير الرقم 23 لرقم اللون الذي تحب Private Sub Worksheet_Activate() For Each ce In Range("A1:" & Cells.SpecialCells(xlCellTypeLastCell).Address) If ce.Value <> Sheet1.Range(ce.Address) Then ce.Interior.ColorIndex = 23 End If Next End Sub أو تفضل المرفق Classeur1_3.rar

السلام عليكم أخي العزيز السؤال غير واضح حل سريع ضع عنوان في الخلية A1 مثل "التاريخ" أو "Date" إنسخه أو كرره في خلية أخري بعيدة ولتكن J1 ظلل المجال الذي فيه التاريخ الأول (في المثال تبعك سيكون A1:A18) ثم من قائمة بيانات (Data) ثم Filter ثم Advanced List Range سيكون يساوي A1:A18 إختر Copy to Another Location وإختر Unique Record Only وفي خانة Copy To إختر J1 التي وضعت بها نسخة العنوان ثم إضغط OK

السلام عليكم أخي العزيز (الاب الروحى) رأيت حلك وهو ممتاز لكن إن كانت الضرائب غير 10% ؟؟؟ الأفضل ألا تجعلها قاصرة علي 10% فلعل السائل أعطاها كمثال فقط ويكون ممن ضمن السلع من ضريبته أكثر أو أقل من 10%

السلام عليكم أخي الكريم تفضل الملف وبه الشرح Test22.rar

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

يبدو أنها لاتعمل مع إكسل 2003 إذا عندك 2007 أو مافوقه ظلل المساحة في الورقة الثانية bd2 من أول خلية A1 حتي آخر خلية بها بيانات ، علي أن تكون الخلية النشطة (التي تبدأ من عندها التظليل) هي A1 ثم ضع الشرط التالي في التنسيق الشرطي =A1<>'bd1'!A1 أو تفضل الملف xlsx Classeur1_2.rar

تفضل ديون3.rar

السلام عليكم أخي الكريم الكود التالي في حدث تنشيط الورقة الثانية Private Sub Worksheet_Activate() Application.ScreenUpdating = False [A4:G9999].ClearContents With Sheets(1) .AutoFilterMode = False LR = .[A9999].End(xlUp).Row x = "<" & Format(Date, "mm/dd/yyyy") With .Range("A3:G" & LR) .AutoFilter Field:=7, Criteria1:="=" .AutoFilter Field:=6, Criteria1:=x End With nLR = .[A9999].End(xlUp).Row .Range("A3:G" & nLR).Copy .AutoFilterMode = False End With [A9999].End(xlUp).Offset(1, 0).Select Selection.PasteSpecial Paste:=xlPasteValues Range("A4:G4").Delete Shift:=xlUp [A2].Select Application.ScreenUpdating = True End Sub وتفضل المرفق ، به أيضا تنسيق شرطي بالورقة الأولي ديون2.rar

السلام عليكم بالتسيق الشرطي تفضل Classeur1_2.rar

السلام عليكم أخي الكريم فيما يلي شرح للكود بالكامل ، أو لما لم يشرح من قبل في أول الكود (قبل الجزء السابق شرحه) ستجد الأمر [B4:E999].ClearContents والذي يمسح محتويات الخلايا B4:E999 ثم الجزء السابق شرحه والذي ينتهي بعمل نسخ من الفلتر المطلوب وإلغاء الفلتر بالورقة2 يأتي بعد ذلك: [B4].PasteSpecial Paste:=xlPasteValues LR = [D9999].End(xlUp).Row وهذا يجعل لصق المنسخ بداية من الخلية B4 ويحسب مرة أخري رقم آخر صف LR لكن في الورقة Sheet3 وسوف يستخدم هذا في ترتيب الاعمده كما ستلاحظ الأوامر التالية لذلك هي: Range("D4:D" & LR).Cut [C4].Insert Shift:=xlToRight أي أنه يقطع البيانات في العمود D (الكمية) ويضعها قبل C (اجمالى السعر) وحيث أن النسخ واللصق يأتي بصف العناوين أيضا من الورقة2 فستجد بعد ذلك الأمر [A4:D4].Delete Shift:=xlUp LR = LR - 1 واللذي يحذف العناوين المتكررة نتيجة النسخ بالصف 4 ثم ينقص من قيمة LR رقم1 مقابل الصف الذي تم حذفه ثم بعد ذلك If LR < 5 Then Exit Sub وهذا لإحتمال أن نتيجة الفلتر 0 أو 1 صف فقط فلاداعي لما سيلي من الأوامر أما الجزء الأخير فهو المسؤول عن: (1) جمع الكميات والمبالغ وكذلك (2) حذف الاسماء المكرره وستجد شرحه بالصورة المرفقة

السلام عليكم أخي العزيز في هذا الجزء من الكود تجد أن الأمرين تقريبا مثل بعضهما يفصل بينهما أمر تفعيل الفلتر With Sheet2 LR = .[C9999].End(xlUp).Row .Range("B2:F" & LR).AutoFilter Field:=4, Criteria1:=sel nLR = .[C9999].End(xlUp).Row .Range("C2:D" & nLR & ",F2:F" & nLR).Copy .AutoFilterMode = False End With فمجموعة الأوامر السابقة كلها ستحدث بالورقة 2 فقط With Sheet2 بعد أن يكون قد تعرف علي معيار الفلتر من الأمر السابق لهذه الأوامر وهو sel يساوي الخلية C2 يعني يحسب رقم آخر صف LR ويستخدمه في مجال الفلتر ثم بعد عمل الفلتر يحسب رقم آخر صف مرة أخري nLR ويستخدمه في النسخ للورقة التالية

السلام عليكم أخي وأستاذي الفاضل الكريم / عبدالله باقشير الموضوع منور والله مرورك شرف لنا جميعا لم أر طبعا مشاركتك قبل أن أرسل ولكن لزيادة الخير أخي / عادل الكود موجود بالمرفق أيضا تصفية وتجميع3.rar

السلام عليكم أخي الكريم ضع الكود التالي في حدث الورقة 3 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$C$2" Then Exit Sub [B4:E999].ClearContents sel = [C2] With Sheet2 LR = .[C9999].End(xlUp).Row .Range("B2:F" & LR).AutoFilter Field:=4, Criteria1:=sel nLR = .[C9999].End(xlUp).Row .Range("C2:D" & nLR & ",F2:F" & nLR).Copy .AutoFilterMode = False End With [B4].PasteSpecial Paste:=xlPasteValues LR = [D9999].End(xlUp).Row Range("D4:D" & LR).Cut [C4].Insert Shift:=xlToRight [A4:D4].Delete Shift:=xlUp LR = LR - 1 If LR < 5 Then Exit Sub For r = 4 To LR For nr = r + 1 To LR If Cells(nr, 2) = Cells(r, 2) Then Range("C" & nr & ":D" & nr).Copy Cells(r, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd Range("B" & nr & ":D" & nr).Delete Shift:=xlUp End If Next nr Next r End Sub

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

السلام عليكم أخي الكريم بالمرفق محاولة مبدئية لضيق الوقت وضعت بيانات وهمية في الـ 26 ملف (RAND) الكود مؤقتا يعتمد علي أن الملفات كلها إسمها Data file n.xls والبيانات في كل شيت 10 أسطر فقط تفضل Data file.rar

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

السلام عليكم أخي العزيز إستبدل المعادلة بمعادلة Vlookup فهي الأفضل في هذه الحالة =IFERROR(VLOOKUP(F5,$B$4:$C$18,2),0) حساب النقاط SUMIF2.rar

السلام عليكم تفضل بالمرفق يوجد إسم مكون بالإكسل "aa" وهذا يأخذ قيمة عند التفعيل ولتكن 4 وكود المنع لايعمل إلا إذا كان هذا الإسم =4 أما كود عدم المنع فيعطي نفس الإسم أي قيمة أخري Book1_Taf3eel.rar

تطبيق الماكرو على اكثر من خليه السلام عليكم الأخت الفاضلة (عفوا لم أنتبه للإسم من قبل) أولا الكود الموجود أصلا يمكن إختصاره بدلا من Private Sub CommandButton1_Click() With WorksheetFunction If Sheets("Sheet1").Range("b2").Value >= .VLookup(Sheets("Sheet1").Range("a2"), Sheets("Sheet2").Range("d5:e10"), 2, False) Then Sheets("Sheet1").Range("c2").Value = Sheets("Sheet1").Range("b2").Value - .VLookup(Sheets("Sheet1").Range("a2"), Sheets("Sheet2").Range("d5:e10"), 2, False) Sheets("Sheet1").Range("b2").Value = .VLookup(Sheets("Sheet1").Range("a2"), Sheets("Sheet2").Range("d5:e10"), 2, False) Else Sheets("Sheet1").Range("c2").Value = 0 End If End Sub للكود التالي (لم أغير شيء ، نفس الأوامر) Private Sub CommandButton1_Click() x = WorksheetFunction.VLookup([a2], Sheet2.[d5:e10], 2, 0) If [b2] >= x Then [c2] = [b2] - x: [b2] = x Else [c2] = 0 End Sub ثانيا: إن كنت تعني تكرار ذلك علي باقي القيم في العمود A فماعليك إلا جعل الأوامر السابقة في حلقة وتغيير الخلايا الثابتة بعناوين متغيرة حسب الصف ، ليكون الكود هكذا Private Sub CommandButton1_Click() LR = [A9999].End(xlUp).Row For r = 2 To LR x = WorksheetFunction.VLookup(Cells(r, 1), Sheet2.[d5:e10], 2, 0) If Cells(r, 2) >= x Then Cells(r, 3) = Cells(r, 2) - x: Cells(r, 2) = x Else Cells(r, 3) = 0 Next r End Sub

السلام عليكم إخواني وأحبائي عباد (العيدروس) عادل ابوزيد فضل لاأستطيع الرد علي كلماتكم الرقيقة المليئة بالمشاعر الطيبة هذه إلا بالدعاء بدوام مابيننا جميعا في طاعته عز وجل - جزاكم الله جميعا خير الجزاء

السلام عليكم عندك حق أخي الكريم ، فقد اسخدمت متغيرات كثيرة لتناسب طلبك وهذه بعضها الإسم nm : name الصف الجديد nr : new row LastColumn lc اخر عمود rw الصف mx الصف الأقصي date التاريخ d عمود الشهر Month Column mc" وفي المرفق تجد الملف وبه الأمر الأمر الذي أضفناه ردا علي مشاركة أخونا hamada21 وتجد كذلك ورقة إضافية بها شرح مطول للكود تفضل الغياب3.rar

السلام عليكم نعم حلها سهل ، إمسح البيانات من الصفحة قبل بدء الجلب وذلك بإضافة السطر [B16:J9999].ClearContents إلي أول الكود ليصبح Sub get_data() [B16:J9999].ClearContents Sheets(2).Activate ..

الأخت الكريمة أفضل من يرد عن هذا هو صاحب الموضوع ولكن حسبما فهمت ، أن رقم 1 ،2 أرقام مجازية في حين أر نرقم العقد سيكون كبيرا مثلا 225014 ولكن عندك حق ، قد يكون هناك سيريال للعقود كلها أصلا ننتظر رد صاحب الموضوع (أ/أحمد صاحب)

السلام عليكم تفضل المرفق الغياب2.rar

إخواني وأحبائي (أبو ملك / عبد الحميد شقير / ابوجادالله) جزاكم الله جميعا خير الجزاء