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

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

أخي الكريم أنا لا أرفق الملفات في الطلبات إلا للضرورة القصوى لابد من معرفة الأساسيات للتعامل مع الأكواد افتح محرر الأكواد عن طريق Alt + F11 .. قم بإدراج موديول جديد من قائمة Insert ثم Module انسخ الكود من الموضوع والصقه في الموديول .. احفظ الملف ..إذا ظهرت لك رسالة فيها Yes و No و Cancel ، اختر الخيار No وغير امتداد الملف ليقبل الأكواد Macro-Enabled ... أخيراً اذهب لمحرر الأكواد مرة أخرى ومن قائمة Tools ثم References أضف المكتبة المشار إليها في أول الكود وهي Microsoft Script Runtime .. الآن قم بربط الكود بزر أمر أو أي شكل وشغل الكود إذا واجهتك مشكلة حاول تضع صورة للمشكلة لكي يتسنى تقديم المساعدة المطلوبة تقبل تحياتي

يرجى عدم وضع اقتباسات طويلة .. المهم كيف وضعته؟ .. ما المشكلة التي حدثت معك بالضبط كن دقيقاً في وصف المشكلة لتجد المساعدة بشكل أفضل

بارك الله فيك أخي الغالي الشهابي ..كود جميل ولم أفهم المطلوب إلا بالإطلاع على الكود .. قمت بإعادة عمل الكود باستخدام المصفوفات من باب اثراء الموضوع .. أرجو أن يفي بالغرض إن شاء الله قم بوضع الكود التالي في موديول عادي Sub Observation() Dim data As Worksheet Dim ws As Worksheet Dim sh As Worksheet Dim f As Boolean Dim arr As Variant Dim temp() As Variant Dim temp2() As Variant Dim i As Long Dim j As Long Dim x As Long Dim last As Long Set data = Sheets("بيانات") Set ws = Sheets("الساقية") Set sh = Sheets("الملاحظة") arr = ws.Range("B7:O" & ws.Cells(Rows.Count, 3).End(xlUp).Row).Value ReDim temp(0) ReDim temp2(0) With Application .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False End With sh.Range("B10:F39,C42:C45").ClearContents For j = 1 To UBound(arr, 2) If arr(1, j) = sh.Range("J3").Value Then f = True: Exit For Next j If f Then For x = 1 To 15 For i = 2 To UBound(arr, 1) If arr(i, j) = x Then temp(UBound(temp)) = arr(i, 2) ReDim Preserve temp(UBound(temp) + 1) End If Next i Next x For i = 2 To UBound(arr, 1) If arr(i, j) = "ح" Then temp2(UBound(temp2)) = arr(i, 2) ReDim Preserve temp2(UBound(temp2) + 1) End If Next i ReDim Preserve temp(UBound(temp) - 1) ReDim Preserve temp2(UBound(temp2) - 1) last = UBound(temp) + 10 sh.Range("C10").Resize(UBound(temp) + 1).Value = Application.Transpose(temp) sh.Range("C42").Resize(UBound(temp2) + 1).Value = Application.Transpose(temp2) sh.Range("B10:B" & last).Value = data.Range("B4:B" & last).Value sh.Range("D10").Resize(UBound(temp) + 1, 3).Value = data.Range("C4:E" & last).Value End If With Application .ScreenUpdating = True: .Calculation = xlAutomatic: .EnableEvents = True End With End Sub ثم ضع الكود التالي في حدث ورقة العمل المسماة "الملاحظة" Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("J3")) Is Nothing Then Call Observation End If End Sub

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

الحمد لله أن تم المطلوب على خير ، والحمد لله الذي بنعمته تتم الصالحات تقبل تحياتي

ما هي نسخة الأوفيس لديك وما إصدار الويندوز وهل الويندوز 32 بت أم 64 بت؟ وهل الكود لا يعمل على الإطلاق أم تظهر رسالة خطأ .. سيظهر في الفورم زر للتكبير وللتصغير وهذا ما يقوم به الكود ..أما زر الأمر المكتوب عليه "تصغير الفورم" فلا يرتبط بكود .. المزيد من التوضيح للمشكلة يساعد في حلها بسرعة وبكفاءة

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

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

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

أخي الكريم خالد الملف المرفق لا يتم تحميله ، يرجى إعادة رفع الملف مرة أخرى والأفضل إرفاق بعض النتائج المتوقعة

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

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

تفضل أخي الكريم من هنا وهذا رابط آخر لبرنامج آخر من هنا لكيفية التحميل من على موقع الرفع شاهد الفيديو التالي من هنا

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

هل كود الصنف يتكرر في الورقة الواحدة ؟؟ أم أنه يتواجد مرة واحدة فقط؟

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

ارفق بعض النتائج المتوقعة ..ونظم أفكارك

جرب الكود التالي Sub ListUnique() 'Reference : Microsoft Scripting Runtime '--------------------------------------- Dim d As Scripting.Dictionary Dim r As Long Dim m As Long Set d = CreateObject("Scripting.Dictionary") m = Range("A" & Rows.Count).End(xlUp).Row For r = 1 To m If Range("B" & r).Value <> "" And IsNumeric(Range("B" & r).Value) And Range("A" & r).Value <> "المجموع" Then If Not d.Exists(Key:=Range("A" & r).Value) Then d.Add Key:=Range("A" & r).Value, Item:=Range("B" & r).Value Else d(Range("A" & r).Value) = d(Range("A" & r).Value) + Range("B" & r).Value End If End If Next r Range("F:G").ClearContents Range("F2:G2").Value = Array("اسم الموظف", "مجموع المكافآت") Range("F3").Resize(d.Count, 1).Value = Application.Transpose(d.Keys) Range("G3").Resize(d.Count, 1).Value = Application.Transpose(d.Items) Set d = Nothing End Sub

جرب الكود في حدث ورقة العمل Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Column = 1 Then Dim sh As Worksheet, Found Set sh = Sheets("DATA") Application.ScreenUpdating = False Application.EnableEvents = False On Error GoTo Skipper Found = Application.Match(Target.Value, sh.Columns(1), 0) Target.Resize(1, 4).Value = sh.Cells(Found, 1).Resize(1, 4).Value Skipper: Application.EnableEvents = True Application.ScreenUpdating = True End If End Sub

يرجى رفع الملف مرة أخرى ..

ارفق ملف لتجد المساعدة من إخوانك بشكل أفضل ويفضل أن يكون نموذج مصغر من الملف الأصلي ..

اضغط على Edit Anyway ...

السلام عليكم أخي الحبيب محمود حمداً لله على سلامتك وأسأل الله العظيم رب العرش العظيم أن يشفيك لكم نفتقد تواجدك فيما بيننا ..سلمك الله من كل سوء ومن كل شر ، وفرج عنك كل كرب