نجوم المشاركات

السلام عليكم ورحمة الله وبركاته هل فكرت يوماً في إدراج صور داخل تعليق ؟ ماذا لو كنت تريد إدراج مجموعة كبيرة من الصور داخل التعليق مرة واحدة؟ اليوم أقدم لكم تنفيذ هذه الفكرة ، وهي إدراج مجموعة من الصور في تعليقات بناءً على قائمة بأسماء ملفات الصور توضع في العمود الأول. تجهيز الملف : قم بإدراج أسماء ملفات الصور في النطاق A2:A7 على سبيل المثال (يمكن تغيير النطاق داخل الكود بما يتناسب مع ملفك) * ملحوظة : أسماء ملفات الصور تكون ملحقة بالامتداد ، على سبيل المثال Pic01.JPG قم بتغيير المسار من سطر تحديد المسار داخل الكود ، وفي النهاية قم بتنفيذ الكود ، ليقوم الكود بإدراج الصور في الخلايا المجاورة في العمود الثاني. هذه صورة من الملف بعد تنفيذ الكود لمزيد من التفاصيل قم بزيارة رابط الموضوع الأصلي من هنا

جزاكم الله خيراً أخي الغالي جلال أسعى دائماً وأبداً أن أقوم بتعليم إخواني ما أتعلمه ..أقدمه بأسلوب بسيط يسهل على الجميع فهمه وتطبيقه لكي نتعلم ونرتقي وهذا ما أطمحه من جميع المعلمين في هذا المجال تقبل وافر تقديري واحترامي

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

بسم الله الرحمن الرحيم اقدم لكم كود بحث متقدم كود بحث متقدم يفوق معظم أنواع البحث بالاعتماد على المصفوفات لضمان كفاءة عالية للبحث وسرعة جلب البيانات والمرونة العالية به من حيث البحث داخل كل الأعمدة الموجودة داخل النطاق تم توضيح المتغيرات التي تستطيعوا تعديلها لتتوافق مع ملفاتكم الكود المستخدم داخل الملف Sub Yasser_Serch() Dim myArray, lr, X, targt, targtN Dim SERCH As Worksheet, DATA As Worksheet '____________________________________________ Set DATA = Worksheets("Sheet2") 'اسم شيت قاعدة البيانات Set SERCH = Worksheets("Sheet1") 'اسم الشيت الخاص بالبحث '____________________________________________ lr = DATA.Cells(Rows.Count, 1).End(xlUp).Row 'اخر صف به بيانات SERCH.Range("A4:J" & SERCH.Cells(Rows.Count, 4).End(xlUp).Row + 1).ClearContents 'مسح نطاق البحث القديم targt = SERCH.Range("e1").Value 'خلية البحث targtN = Application.WorksheetFunction.Match(SERCH.Range("D1"), SERCH.Range("A3:J3"), 0) 'دالة لايجاد رقم عمود البحث myArray = DATA.Range("A2:J" & lr + 1) 'نطاق قاعدةالبيانات الذي سيتم البحث فيه '____________________________________________ ReDim Y(1 To lr, 1 To 10) For X = 1 To lr If targt = "" Then Exit Sub If myArray(X, targtN) Like targt & "*" Then rw = rw + 1 Y(rw, 1) = myArray(X, 1): Y(rw, 6) = myArray(X, 6) Y(rw, 2) = myArray(X, 2): Y(rw, 7) = myArray(X, 7) Y(rw, 3) = myArray(X, 3): Y(rw, 8) = myArray(X, 8) Y(rw, 4) = myArray(X, 4): Y(rw, 9) = myArray(X, 9) Y(rw, 5) = myArray(X, 5): Y(rw, 10) = myArray(X, 10) End If Next X If rw > 0 Then SERCH.Cells(Rows.Count, 1).End(xlUp)(2, 1).Resize(rw, 10).Value = Y() End Sub لتحميل الملف اضغط هنا اعداد / ياسر العربي تقبلو تحياتي

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

ربنا يبارك فى عمرك ويحميك ابا البراء تقبل خالص تحياتى وتقديرى

بسم الله الرحمن الرحيم طلب بعض الاخوة موضوع الوارد اولا صادر اولا (FIFO) قمنا بعمل مثال بالاكواد لحل هذه المشكلة المثال يعتمد على اعمدة مساعدة ويتم مسح البيانات منها بعد الانتهاء الكود المستخدم Sub YasserFIFO() Dim z As Byte Application.ScreenUpdating = False Range("K6:K23").ClearContents Range("D6:E23").Copy Range("R1") Range("r1:s18").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp Range("G6:G23").Copy Range("T1") z = 1 For Each x In Range("g6:g23") If x.Value <> "" Then If x.Value <= Cells(z, 18) Then Cells(x.Row, 11) = Cells(z, 19) * x.Value Cells(z, 18) = Cells(z, 18) - x.Value ElseIf x.Value > Cells(z, 18) Then 3 Cells(x.Row, 11) = Cells(x.Row, 11) + (Cells(z, 18) * Cells(z, 19)) x.Value = x.Value - Cells(z, 18) Cells(z, 18) = 0 For z = 1 To 20 If Cells(z, 18) = 0 Then GoTo 1 If Cells(z, 18) >= x.Value Then GoTo 2 If Cells(z, 18) < x.Value Then GoTo 3 1 Next z 2 Cells(x.Row, 11) = Cells(x.Row, 11) + (Cells(z, 19) * x.Value) Cells(z, 18) = Cells(z, 18) - x.Value End If End If Next Range("T1:T18").Copy Range("G6:G23") Range("R1:T18").Clear Range("a1").Activate Application.ScreenUpdating = True End Sub ومرفق المثال تستطيعوا تكبير المدى او جعله مرن بالتعديل على النطاقات الموجودة بالكود FiFo_2.rar

السلام عليكم معذرة على التاخير في رفع دروس جديدة ولكن ان شاء الله كلما تيسر الوقت ساضيف درس جديد والان اترككم مع الدرس وان شاء الله تعم الفائدة

الحمدلله وبعد جهد جهيد وجدت ضالتي في هذه الساعة، وبالرغم من توفر بعض الساعات النادرة في ملفات الإكسيل، إلا أنها تعيبها بعض الأمور منها: 1- عمل الساعة في الخلفية مما يعطل تنفيذ بعض الأوامر وتجميد ورقة العمل. 2- رتابة التصميم. 3- عدم توافقها لبعض إصدارات الإكسيل والوندوز. ولذلك تم تفادي هذه المشاكل مع إمكانية التصميم المرن للساعة حيث أننا فصلنا كل رقم من الساعة (digit) ليعمل بشكل منفصل ومترابط مع الأجزاء الأخرى، وكل من يشاهد التصميم يتوق بأنه قد تم برمجته بلغات الويب المتقدمة كالجافا.. نتمنى أن ينال إعجابكم ولا تنسونا من الدعاء clock03.rar

الله يجزيك خير عارف ان حضرتك مش هاتقصر

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

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

و يشرفنى أن أكون أحد تلاميذك لعلمك وتواضعك وقوة الارادة لديك تحياتى

وعليكم السلام بالتسيق الشرطي جرب الملف التالي تلوين خلية.rar

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

ما شاء الله عليك أستاذى سلمت يمينك ابا البراء أنا أغبطك بجد ( العين عليها حارس لربما حد يفتكرها حاجة تانى )

استاذنا الغالى واخينا الحبيب لك كل تحية احترام وتقدير ووحشتنا كتير لم نرك منذ فتره كبيره لعل المانع خير ان شاء الله تقبل تحياتى واحترامى

أخي الغالي مختار حسين تفضل باستخدام المصفوفات Sub Using_Arrays() Dim Arr As Variant Dim Temp As Variant Dim I As Integer Dim J As Integer Dim P As Integer Dim Cnt As Integer Dim tSum As Double Range("C6:I9").ClearContents Arr = Range("L5:R9").Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2) + 1) For I = 2 To UBound(Arr, 1) Cnt = 0: tSum = 0 For J = LBound(Arr, 2) To UBound(Arr, 2) If Not IsEmpty(Arr(I, J)) Then Temp(I - 1, Cnt + 1) = Arr(I, J) Temp(I - 1, Cnt + 2) = Arr(1, J) tSum = tSum + Arr(I, J) P = P + 1 Cnt = Cnt + 2 End If Next J Temp(I - 1, UBound(Temp, 2) - 1) = tSum Cnt = Cnt + 2 Next I Range("C6").Resize(UBound(Temp, 1), UBound(Temp, 2)).Value = Temp End Sub

اخي الكريم ذكرت أن هذا الحل هو للطلب الثاني فهل كان الحل الذي تريد ؟ بالنسبة للطلب الاول فالمعذرة وأتمنى من الاخوة العمل على ذلك ملاحظة : ملفك المرفق يوجد فيه مشكلة في ظهور الفورم عند فتح الملف وقد تداركت ذلك اليك الرفق ‫برنامج حالات %5اصابة 1.rar

اخي الكريم كريم فيما يخص الطلب الثاني شاهد المرفق ‫برنامج حالات %5اصابة 1.rar

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

أخي الكريم جرب الملف التالي عله يفي بالغرض إن شاء الله رابط الملف من هنا

الف شكر لحضرتك وربنا يجزيك خير شكرا جزيلا لإهتمامك الف شكر لحضرتك وربنا يجزيك خير شكرا جزيلا لإهتمامك

السلام عليكم ورحمة الله وبركاته إخواني الأحباب سبق أن قمنا بكسر حماية محرر الأكواد بدون برامج .. الآن مع كسر حماية أوراق العمل بالاستعانة ببرنامج صغير الحجم اسمه XML Marker وهو برنامج للتعديل على ملفات الـ XML وهو مرفق في الموضوع ... أترككم مع الفيديو ..عسى أن تستفيدوا منه إن شاء الله (ومتنسوش اللايكات !!) تقبلوا تحيات أخوكم أبو البراء xmlmarker_2_2_setup.rar

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

هذا بالضبط الي كنت احتاجه .. شكرا عالمساعده افدتني كثير .. بس لو تشرح لي اللي سويته عشان اتعلم اكون شاكره لك جزاك الله خير

يا اخ عبدالله سبقتني تحياتي الك

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

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

جرب هذا الماكرو Sub Salim() Dim Mg As Range Set Mg = Range("p1:p4") With Range("B6:N22") .HorizontalAlignment = xlGeneral .Font.Size = 16 End With For i = 6 To 22 With Range("b" & i) For j = 1 To 4 If .Value = Mg.Cells(j) Then .Font.Size = 24 .Resize(1, 13).HorizontalAlignment = xlCenterAcrossSelection End If Next End With Next End Sub لك ما تريد تم التعديل قليلاً على الماكرو ليعمل بشكل اسرع للبيانات الكثيرة Sub Salim1() Dim lr As Integer Application.ScreenUpdating = False If ActiveSheet.Name <> "ورقة1" Then Exit Sub lr = Cells(Rows.Count, 2).End(3).Row With Range("B6:N" & lr) .HorizontalAlignment = xlGeneral .Font.Size = 16 End With For i = 6 To lr With Range("b" & i) On Error Resume Next t = Application.WorksheetFunction.Match(Range("b" & i), Range("p1:p4"), 0) If t Then .Font.Size = 24: .Resize(1, 13).HorizontalAlignment = xlCenterAcrossSelection End With t = 0 On Error GoTo 0 Next Application.ScreenUpdating = True End Sub

الاخ جلال الجمال_ابو أدهم تحياتي لك اعدت ذكري الزمن الجميل شكرا لك

بس تعال ياباشا لو عايزين ننقل كل العناصر !!

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

الشكر لله اخي ابو هديل والحمد لله الذي تتم الصالحات على يدة .

نعم مفتوحين لسا المشكلة موجوده ماتتنقل البيانات

هل النموذجين مفوحين ولا لا ؟ لازم بيكون النوزجين مفتوحين

جربت لكن مافي نتيجه.. :( وانا اسفه على تكرار الموضوع كانت في مشكله فالنت

اولا يجب ان يكون النموذجين مفتوحين وفي حدث عند النقر على الزر في محرر الاكواد اكتب Forms!form4!Text0 = Me.Text0 فورم!اسم الفورم ! اسم الحقل = اي حقل تريد يأخذ منه نصه مع التقدير

تم حل المشكلة تفضل جدول6.rar

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

اعمال رائعة جدا ربنا يقويكون ويزيدكون علم

بعد اذن الاخ الكريم عماد محمد تم رفع الملف على المنتدى ليستفاد منه الجميع سلمت يداك بكل خير اخى عماد برنامج مخازن معدل جديد.rar

استبدل الدالة acExportDelim الموجودة داخل الكود بهذه acExportMerge الاخيرة تزيل الفواصل

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

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

أخي الحبيب محمد تفضل الملف المرفق ...كل ما عليك أن تضع أوراق العمل المطلوب جلب البيانات منها في مصفوفة بالترتيب الذي ترغب التعامل معه Sub CollectDataFromSheets() Dim MyArray As Variant, Item Dim LR As Long MyArray = Array("خط التعبئة والتغليف", "خط الاستلام والتجهيز", "1", "2", "3") Application.ScreenUpdating = False Sheets("شيت مجمع").Range("A3:H1000").ClearContents For Each Item In MyArray With Sheets(Item) .Activate LR = .Cells(300, 2).End(xlUp).Row .Range("B5:H" & LR).Copy With Sheets("شيت مجمع") .Range("B" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).PasteSpecial xlPasteValues .Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row + 1 & ":A" & .Cells(Rows.Count, 2).End(xlUp).Row) = Sheets(Item).Name End With End With Next Item Sheets("شيت مجمع").Activate: Range("A1").Select Application.CutCopyMode = False Application.ScreenUpdating = True End Sub ويتم ذلك من خلال السطر الرابع إليك الملف المرفق للتجربة ولا تنسى أن تحدد المشاركة التي تعجبك كأفضل إجابة ليظهر للأخوة الأعضاء أن الموضوع مجاب ، وعشان آخد نقطة (بعد التعب دا كله) تقبل تحياتي Collect Data From Sheets V2.rar

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

ولاثراء الموضوع ولاضافة التاريخ في خلايا العمود B بناءا علي الكتابة في العمود A واضافة للكود الخاص بالاخ / ابو غريب شاهد المرفق ... حيث عندما لايكون بالخلية شئ يتم مسح التاريخ Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.Count > 1 Then Exit Sub If Not Intersect(Target, Range("a2:a10000")) Is Nothing Then VBA.Calendar = vbCalGreg If IsEmpty(Target) Then Target(1, 2).ClearContents Else With Target(1, 2) .Value = Date .EntireColumn.AutoFit End With End If End If End Sub جزاكم الله خيرا اضافة تاريخ في خلايا عمود بناءا علي خلايا عمود آخر.rar

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاتة إدراج الصـورة فـى تعليق الخليـة أتـومـاتيكيـا مع التحكم بحجمها سبق ان قدمت على الرابط التالى ::: اضافة صورة الى تعليق الخلية ولكن بطريقة يدوية ولكن اليوم سيكون بطريقة اتوماتيكية اى يدرج جميع الصور فى التعليق بصورة اليه كل المطلوب منك هو الاتى ::: بعد نقل الكود الى ملفك فى نفس فلدر الملف الخاص بك اصنع فلدر بأسم ( AllPic ) وضع فيه الصور المراد ادراجها وبعد ادراج الصور فى التعليقات يمكنك حذف فلدر الصور فلا حاجة لك به بعد ادراجها التنفيذ ::: قف فى اول خلية فى العمود الذى به اسماء الصور وأضغط الزر ولك ان تختار احد ثلاث طرق بالنسبة الى حجم الصور المدرجة فى التعليقات الحجم الاول ::: ان تكون الصور بنفس حجم التعليق بالسنتيمتر يكون عرض الصورة يساوى ( 3.5 ) سم وبإرتفاع قدرة ( 2 ) سم الحجم الثانى ::: ان تكون الصور بنفس حجم الصور الطبيعى اى كان هذا الحجم او اختلاف مقاسات الصور الحجم الثالث ::: وهنا يمكنك ان تحدد مقاس ثابت لجميع الصور كما تشاء فيمكن مثلا ان تكون الصور فى مقاس 4 سم للعرض و 6 سم للأرتفاع او اى مقاس ترغب المرفق الاول ::: ملف البرنامج + فلدر به بعض الصور للتجربه Omar_1.rar المرفق الثانى ::: ملف فيديو يوضح طريقة العمل Insert_Comment.rar تحياتى لجميع الاخوة