ياسر خليل أبو البراء

جزيت خيراً أخي الغالي وأستاذي الكبير رجب تقبل وافر تقديري واحترامي

مشوار الألف ميل بيبدأ بموضوع ..المهم المبادرة ..كلما تعلمت جديداً قمت بنقله لإخوانك لتستفيد قبل أن تفيد تقبل تحياتي

أخي الكريم فارس إليك الكود التالي عله يكون المطلوب Sub ExtractUnique_Count() Dim R1 As Range, R2 As Range, Cel As Range, LR As Long Dim D1, D2, A1, A2 LR = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row Set R1 = Sheet1.Range("B2:B" & LR) Set R2 = Sheet1.Range("D2:D" & LR) Set D1 = CreateObject("Scripting.Dictionary") Set D2 = CreateObject("Scripting.Dictionary") On Error Resume Next Sheet3.Range("A2:E1000").ClearContents For Each Cel In R1 If Cel <> 0 Then D1.Add CStr(Cel), CStr(Cel) Next Cel A1 = D1.Items For Each Cel In R2 If Cel <> 0 Then D2.Add CStr(Cel), CStr(Cel) Next Cel A2 = D2.Items Sheet3.Range("A2").Resize(D1.Count) = Application.Transpose(A1) With Sheet3.Range("B2").Resize(D1.Count) .Formula = "=COUNTIF(ورقة1!$B$2:$B$1000,A2)" .Value = .Value End With Sheet3.Range("D2").Resize(D2.Count) = Application.Transpose(A2) With Sheet3.Range("E2").Resize(D2.Count) .Formula = "=COUNTIF(ورقة1!$D$2:$D$1000,D2)" .Value = .Value End With End Sub وإليك الملف المرفق فيه تطبيق للكود تقبل تحياتي Extract Unique Items & Count Them YasserKhalil.rar

صراحة لقد تعبت من التعديل في الكود وأشعر أنني لم أعد أفهم المطلوب على الإطلاق إليك آخر تعديل سأقوم به (عندي مشاغل خاصة وسأغيب عن المنتدى لهذه الليلة ) إذا لم يكن المطلوب أرجو تدخل أحد الأخوة لتقديم المساعدة Sub TransferMatchingData() Dim vItems As Variant, vData As Variant, vOut As Variant, I As Long vItems = Sheet1.Range("B8", Sheet1.Cells(Rows.Count, "B").End(xlUp)).Resize(, 4).Value With Sheet2.Range("B8", Sheet2.Cells(Rows.Count, "B").End(xlUp)) vData = .Value vOut = .Offset(, 1).Resize(, 3).Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For I = LBound(vItems) To UBound(vItems) .Item(vItems(I, 1)) = vItems(I, 4) & "|" & vItems(I, 3) & "|" & vItems(I, 2) Next I For I = LBound(vData) To UBound(vData) If .Exists(vData(I, 1)) Then vOut(I, 1) = Split(.Item(vData(I, 1)), "|")(2) vOut(I, 2) = Split(.Item(vData(I, 1)), "|")(1) vOut(I, 3) = vOut(I, 3) + Split(.Item(vData(I, 1)), "|")(0) Else vOut(I, 1) = "" End If Next I End With .Offset(, 1).Resize(, 3).Value = vOut End With End Sub تقبل تحياتي

جرب التعديل التالي Sub TransferMatchingData() Dim vItems As Variant, vData As Variant, vOut As Variant, I As Long vItems = Sheet1.Range("B8", Sheet1.Cells(Rows.Count, "B").End(xlUp)).Resize(, 4).Value With Sheet2.Range("B8", Sheet2.Cells(Rows.Count, "B").End(xlUp)) vData = .Value vOut = .Offset(, 1).Resize(, 3).Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For I = LBound(vItems) To UBound(vItems) .Item(vItems(I, 1)) = vItems(I, 4) & "|" & vItems(I, 3) Next I For I = LBound(vData) To UBound(vData) If .Exists(vData(I, 1)) Then vOut(I, 1) = Split(.Item(vData(I, 1)), "|")(0) vOut(I, 2) = Split(.Item(vData(I, 1)), "|")(1) vOut(I, 3) = vOut(I, 3) + vOut(I, 1) Else vOut(I, 1) = "" End If Next I End With .Offset(, 1).Resize(, 3).Value = vOut End With End Sub بالنسبة للإضافة المطلوبة أعتقد أنه تم العمل عليها من قبل في كود منفصل يمكنك استدعاء الكود المنفصل في الكود الأساسي باستخدام كلمة Call ثم اسم الإجراء الفرعي المراد تنفيذه ولا أرى داعي لعمل الأكواد في كود واحد لأنه يمكنك إنشاء وكتابة العديد من الأكواد واستدعاء كل الأوامر من خلال إجراء فرعي واحد تقبل تحياتي

أخي الفاضل عبد الله الملف يعمل لدي بشكل جيد ولا أرى أية أخطاء ..ربما تكون نسخة الأوفيس لديك نسخة قديمة لذا أنصح بتحديث نسخة الأوفيس (نحن في 2016 وما زلنا نركن لأوفيس 2003 ..معظمنا وليس الكل) قم بإرفاق صورة من الخطأ الذي يظهر لديك لربما نجد لك حلاً بديلاً تقبل تحياتي

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

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

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

أخي الكريم أبو أنس يرجى إرفاق ملف مع مزيد من التوضيح للمطلوب لتجد الاستجابة من قبل إخوانك .. تقبل تحياتي

أخي الكريم عبد الله يفضل دائماً وضع أي طلبات جديدة في موضوعات منفصلة (راعي هذه النقطة أخي الفاضل) إليك الملف المرفق فيه ما تريد إن شاء المولى تقبل تحياتي Calculate Difference Between Two Dates In Days & Hours & Minutes.rar

أخي الغالي أبو يوسف وعليكم السلام ورحمة الله وبركاته لقد جربت ملفك ووجدت أن عملية التصفية تتم بشكل تلقائي بناءً على الخلية G3 ومن ثم فإن البيانات يتم تحديثها تبعاً لتلك الخلية التي يقوم الكود بتغيير قيمتها في كل حلقة تكرارية أرجو أن يفي بالغرض .. إن شاء الله

أخي الحبيب أبو يوسف جرب الكود التالي عله يكون المطلوب Sub طباعة() Dim I As Long For I = Range("J1").Value To Range("K1").Value Range("G3").Value = I ActiveWindow.SelectedSheets.PrintOut Copies:=1 Next I End Sub تقبل تحياتي

أخي الحبيب وأستاذي الغالي رجب بارك الله فيك وجزاك الله خيراً أخي الكريم عبد الرحمن بدوي جرب الملف المرفق التالي فيه تطبيق ما تريد قم بتغيير التوقيت المطلوب تنفيذ الكود فيه ليتم تنفيذه في الوقت المحدد تقبل تحياتي Run Macro At Specific Time.rar

بارك الله فيك أخي الكريم يونس وجزاكم الله كل خير في انتظار المزيد لتفيد إخوانك ، فخيركم من تعلم العلم وعلمه تقبل وافر تقديري واحترامي

أخي الكريم ارفق ملفك لمحاولة العمل عليه .. لتجد المساعدة من إخوانك لا تكتفي بمجرد صورة من الملف (وفر الوقت على إخوانك وارفق ملفك) تقبل تحياتي

أخي الكريم وليد كلمة List ليست كود إنما هو اسم نطاق معرف ..يمكنك الإطلاع على أسماء النطاقات المعرفة من خلال التبويب Formulas ثم Name Manager

أخي الكريم محمد أفضل من الشكر قول "جزاك الله خيراً" .. وفقني الله وإياك لما فيه الخير والصلاح في الدنيا والآخرة وفي انتظار تنفيذك للكود .. تقبل تحياتي

أخي الكريم محمد قم بعمل عمود مساعد ليسهل عليك الأمر ، وفي النهاية يمكنك إخفاء العمود المساعد في الخلية R12 اكتب كلمة "عمود مساعد" .. وضع المعادلة التالية في الخلية R13 =C13&D13&E13&F13 ثم ضع الكود التالي في موديول ونفذ الكود ليقوم بعملية الترتيب كما طلبت Sub SortData() Dim LR As Long LR = Range("B" & Rows.Count).End(xlUp).Row Range("B12:R" & LR).Sort Key1:=Range("R12:R" & LR), Order1:=xlAscending, Header:=xlYes End Sub إليك الملف المرفق بعد إزالة كافة الفورم والموديولات والإبقاء على الكود المطلوب فقط حتى لا يتوه الأعضاء في الطلب ويستطيع من يحمل المرفق أن يفهم المرفق بسهولة يرجى عدم تعدد الطلبات في الموضوع الواحد ..يمكنك طرح موضوع لكل طلب على حدا Sort Data In Ascending Way YasserKhalil.rar الطلب الثاني وهو فتح ملف الورد قم بوضع الكود التالي مع تغيير اسم ملف الورد ليناسب طلبك Dim objWord As Object Set objWord = CreateObject("Word.Application") objWord.Visible = True objWord.Documents.Open (ThisWorkbook.Path & "\Ahmed.docx") objWord.Activate تقبل تحياتي

أخي الكريم سعيد الطلبات الكثيرة في الموضوع الواحد تنفر الأعضاء حتى لو كان الأمر مجرد تعديل كما تراه التعديل يستلزم مراجعة الكود من البداية للنهاية للوصول لحل عموماً جرب التعديل التالي للجزء الأول من طلبك وهو ترحيل الثلاثة أعمدة من C إلى E ..إلى قائمة المخازن (مع الإضافة في كل مرة يتم فيها تنفيذ الكود) Sub TransferMatchingData() Dim vItems As Variant, vData As Variant, vOut As Variant, I As Long vItems = Sheet1.Range("B8", Sheet1.Cells(Rows.Count, "B").End(xlUp)).Resize(, 4).Value With Sheet2.Range("B8", Sheet2.Cells(Rows.Count, "B").End(xlUp)) vData = .Value vOut = .Offset(, 1).Resize(, 3).Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For I = LBound(vItems) To UBound(vItems) .Item(vItems(I, 1)) = vItems(I, 2) & "|" & vItems(I, 3) Next I For I = LBound(vData) To UBound(vData) If .Exists(vData(I, 1)) Then vOut(I, 1) = Split(.Item(vData(I, 1)), "|")(0) vOut(I, 2) = Split(.Item(vData(I, 1)), "|")(1) vOut(I, 3) = vOut(I, 3) + vOut(I, 1) Else vOut(I, 1) = "" End If Next I End With .Offset(, 1).Resize(, 3).Value = vOut End With End Sub تقبل تحياتي

أخي الحبيب أبو يوسف اطلعت على الملف ولا أدري ما المطلوب بالضبط ...حاول تحدد ورقة العمل المطلوب عليها ؟ والنطاق الذي تستخدمه للطباعة ؟ حاولت في الورقة المسماة Report ووجدت أن الخلية J1 فارغة ... !

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

أخي الكريم أهلاً بك في المنتدى ونورت بين إخوانك يرجى تغيير اسم الظهور للغة العربية كما يرجى الإطلاع على التوجيهات في الموضوعات المثبتة في المنتدى لمعرفة كيفية التعامل بشكل أفضل مع المنتدى الموضوع بسيط ولا يحتاج لمساعدة فقط افتح ملف إكسيل وفي الخلية A1 ضع كلمة رقم مسلسل ، وفي الخلية المجاورة B1 ضع كلمة الاسم وفي الخلية التي تليها C1 ضع كلمة اسم الأم ..وهكذا إلى حيث تريد من الأعمدة ويمكنك الإضافة لقاعدة البيانات بكل سهولة كما يمكنك حذف الصفوف في حالة رغبت في ذلك بكل سهولة .. إذا تعثر عليك الأمر أبلغنا فيما تعثرت فيه وإن شاء الله ستجد من يقدم لك يد المساعدة إليك مثال مبسط يمكنك التعلم منه كبداية تقبل تحياتي UserForm Data Entry TextBox.rar

أخي الكريم المسلم العربي أنا لست بسيد أحد إنما أنا عبد لله مثلي مثلك .. نحن أخوة في الله ومن حق الأخوة تقديم يد العون لأخوك المسلم .. تقبل وافر تقديري واحترامي

بارك الله فيك أخي الكريم كريم منور المنتدى .. يرجى فقط تغيير اسم الظهور للغة العربية ويكون معبر عن شخصكم الكريم لاحظت ردودك في أكثر من موضوع ويبدو أن لديك خلفية كبيرة ، وإن شاء الله تساهم في مساعدة إخوانك بالمنتدى تقبل وافر تقديري واحترامي الأخ الكريم أسامة علاوةً على ما تقدم به الأخوة إليك شرح مبسط بالفيديو لكيفية عمل القائمة المنسدلة أرجو أن يفيدك الفيديو ويوصل المعلومة بشكل أدق Watch.rar