اركان الاسلام

بارك الله فيك يا اخي جارى التجربة

ممكن مساعدة يا جماعه جزاكم الله خيرا

هل من مجيب

السلام عليكم ورحمه الله وبركاته اخواني الاعزاء محتاج كود لشيت اكسيل هبعته لعميل السيناريو المطلوب اول ثلاث ايام فترة تجريببه ثم يطلب كود تفعيل وفى حالة نقل الشيت الى جهاز اخر يطلب كود تفعيل جديد نفس فكرة البرامج الجهازه فترة تجريبيه بعدها تفعيل وحماية من النقل

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

عتدى شيت الصقخه الاولى للخامات المقدره والصفحه التانيه للمنصرف الفعلى والصفحه الثالثه لعمل تقرير ومقارنه الغريب انى اول ما اشغل الكود واخلص شغل اول ما اقفل الشيت بيتمسح من على الجهاز نهائى ارجو حل للمشكله دى وده الكود علشان لو ركبته داخل الشيت او ما احفظ هيتمسح وارفقت شيت الاكسيل بنفس ترتيب الصفحات والاعمده والصفوف وبارك الله فيكم جميعا Sub مقارنة_المشاريع() Dim wsArchive As Worksheet, wsIssue As Worksheet, wsReport As Worksheet Dim lastRowArchive As Long, lastRowIssue As Long, lastRowReport As Long Dim i As Long, j As Long, nextRow As Long Dim client As String, itemCode As String, itemName As String Dim materialCode As String, materialName As String Dim dictProjects As Object, key As Variant Dim estimatedQty As Double, estimatedPrice As Double Dim issuedQty As Double, issuedPrice As Double Dim totalEst As Double, totalIss As Double Set wsArchive = ThisWorkbook.Sheets("الارشيف") Set wsIssue = ThisWorkbook.Sheets("اذون الصرف") Set wsReport = ThisWorkbook.Sheets("التقرير النهائى") wsReport.Cells.Clear Set dictProjects = CreateObject("Scripting.Dictionary") lastRowArchive = wsArchive.Cells(wsArchive.Rows.Count, "M").End(xlUp).Row lastRowIssue = wsIssue.Cells(wsIssue.Rows.Count, "A").End(xlUp).Row ' إنشاء قائمة المشاريع من صفحة الارشيف For i = 4 To lastRowArchive client = wsArchive.Cells(i, "M").Value itemCode = wsArchive.Cells(i, "N").Value itemName = wsArchive.Cells(i, "O").Value key = client & "|" & itemCode & "|" & itemName If Not dictProjects.exists(key) Then dictProjects.Add key, key End If Next i ' كتابة الجدول الرئيسي لكل المشاريع wsReport.Range("C5").Value = "اسم العميل" wsReport.Range("D5").Value = "كود الايتم" wsReport.Range("E5").Value = "اسم الايتم" With wsReport.Range("C5:E5") .Font.Bold = True .Interior.Color = RGB(0, 102, 204) .Font.Color = RGB(255, 255, 255) .HorizontalAlignment = xlCenter End With nextRow = 6 For Each key In dictProjects.Keys Dim parts() As String parts = Split(key, "|") wsReport.Cells(nextRow, 3).Value = parts(0) wsReport.Cells(nextRow, 4).Value = parts(1) wsReport.Cells(nextRow, 5).Value = parts(2) nextRow = nextRow + 1 Next key nextRow = nextRow + 2 ' لكل مشروع نكتب جدول تفصيلي For Each key In dictProjects.Keys parts = Split(key, "|") client = parts(0) itemCode = parts(1) itemName = parts(2) ' عناوين الجدول wsReport.Cells(nextRow, 3).Resize(1, 12).Value = Array("اسم العميل", "كود الايتم", "اسم الايتم", "كود الخامه", "اسم الخامه", "كمية مقدرة", "سعر", "إجمالي مقدر", "كمية منصرفة", "سعر منصرف", "إجمالي منصرف") With wsReport.Range(wsReport.Cells(nextRow, 3), wsReport.Cells(nextRow, 14)) .Font.Bold = True .Interior.Color = RGB(204, 255, 255) .HorizontalAlignment = xlCenter End With nextRow = nextRow + 1 ' نبدأ بجمع المواد من صفحة الارشيف For i = 4 To lastRowArchive If wsArchive.Cells(i, "M").Value = client And wsArchive.Cells(i, "N").Value = itemCode Then materialCode = wsArchive.Cells(i, "P").Value materialName = wsArchive.Cells(i, "Q").Value ' التحقق من القيم قبل إضافتها If IsNumeric(wsArchive.Cells(i, "R").Value) Then estimatedQty = wsArchive.Cells(i, "R").Value Else estimatedQty = 0 End If If IsNumeric(wsArchive.Cells(i, "S").Value) Then estimatedPrice = wsArchive.Cells(i, "S").Value Else estimatedPrice = 0 End If ' نبحث في اذون الصرف عن نفس المادة issuedQty = 0 issuedPrice = 0 For j = 2 To lastRowIssue If wsIssue.Cells(j, "B").Value = client And wsIssue.Cells(j, "C").Value = itemCode And wsIssue.Cells(j, "E").Value = materialCode Then If IsNumeric(wsIssue.Cells(j, "G").Value) Then issuedQty = issuedQty + wsIssue.Cells(j, "G").Value End If If IsNumeric(wsIssue.Cells(j, "H").Value) Then issuedPrice = wsIssue.Cells(j, "H").Value ' سعر الكمية المنصرفه End If End If Next j ' نكتب البيانات في الجدول wsReport.Cells(nextRow, 3).Value = client wsReport.Cells(nextRow, 4).Value = itemCode wsReport.Cells(nextRow, 5).Value = itemName wsReport.Cells(nextRow, 6).Value = materialCode wsReport.Cells(nextRow, 7).Value = materialName wsReport.Cells(nextRow, 8).Value = estimatedQty wsReport.Cells(nextRow, 9).Value = estimatedPrice wsReport.Cells(nextRow, 10).Value = estimatedQty * estimatedPrice ' الإجمالي المقدّر wsReport.Cells(nextRow, 11).Value = issuedQty wsReport.Cells(nextRow, 12).Value = issuedPrice wsReport.Cells(nextRow, 13).Value = issuedQty * issuedPrice ' الإجمالي المنصرف nextRow = nextRow + 1 End If Next i ' الآن نبحث عن الخامات المنصرفة التي لم تكن ضمن الخامات المقدرة For i = 2 To lastRowIssue If wsIssue.Cells(i, "B").Value = client And wsIssue.Cells(i, "C").Value = itemCode Then materialCode = wsIssue.Cells(i, "E").Value materialName = wsIssue.Cells(i, "F").Value ' تحقق مما إذا كانت هذه المادة قد تم إضافتها بالفعل ضمن الخامات المقدرة Dim found As Boolean found = False For j = 4 To lastRowArchive If wsArchive.Cells(j, "M").Value = client And wsArchive.Cells(j, "N").Value = itemCode And wsArchive.Cells(j, "P").Value = materialCode Then found = True Exit For End If Next j ' إذا كانت الخامة غير موجودة ضمن المقدرة، نضيفها If Not found Then issuedQty = 0 issuedPrice = 0 If IsNumeric(wsIssue.Cells(i, "G").Value) Then issuedQty = wsIssue.Cells(i, "G").Value End If If IsNumeric(wsIssue.Cells(i, "H").Value) Then issuedPrice = wsIssue.Cells(i, "H").Value End If ' نكتب البيانات في الجدول wsReport.Cells(nextRow, 3).Value = client wsReport.Cells(nextRow, 4).Value = itemCode wsReport.Cells(nextRow, 5).Value = itemName wsReport.Cells(nextRow, 6).Value = materialCode wsReport.Cells(nextRow, 7).Value = materialName wsReport.Cells(nextRow, 8).Value = 0 ' لا يوجد كمية مقدرة wsReport.Cells(nextRow, 9).Value = 0 ' لا يوجد سعر مقدر wsReport.Cells(nextRow, 10).Value = 0 ' إجمالي مقدر = 0 wsReport.Cells(nextRow, 11).Value = issuedQty wsReport.Cells(nextRow, 12).Value = issuedPrice wsReport.Cells(nextRow, 13).Value = issuedQty * issuedPrice ' الإجمالي المنصرف nextRow = nextRow + 1 End If End If Next i ' صفين فاصلين nextRow = nextRow + 2 Next key wsReport.Columns("C:N").AutoFit MsgBox "تم إنشاء التقرير المقارن لكل المشاريع." End Sub New Microsoft Excel Worksheet.xlsx ردإعادة توجيه إضافة تفاعل

بارك الله فيك يا جناب المحترم الكود يعمل بشكل ممتار ليا سؤال هل ممكن اضافه ميزه ارسال الصور

ممكن فيديو الشرح علشان مش فاهم استخدم البرنامج ازاى ورابط الفيديو مش شغال معايا

ارسال رسائل عبر الواتس اب.xlsx شكرا مقدما ارجو عمل اللازم لاتمكن من ارسال الرسائل من خلال الاكسيل لاكبر عدد ممكن من الاشخاص على الواتس ولكم جزيل الشكر

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

السلام عاليكم اخوتى الاعزاء جزاكم الله جميعا خيرا فلقد استفدت منكم الكثير والكثير ارجو المساعده فى عمل معادله للوارد اولا يصرف اولا الوارد اولا يصرف اولا.xlsx

بارك الله فيك ياخى لقد افاد وفاض ووفى واستكفى حبيبي تسلملى

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

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

جربت اكثر من كود لكنه ينقل فى اماكن متفرقه المطلوب ترحيل البيانات من عمو د f و h من الصفحه الثانيه الى العمود i و l فى الصفحه االثالثه ثم مسح البيانات من الصفحه الثانيه ولقد قمت بتلوين الاعمده لتاكيد من العمود الاخضر فى الصفحه الثانيه الى العمود الاخضر فى الصفحه الثالثه ومن العمود الاحمر فى الصفحه الثانيه الى العمود الاحمر فى الصفحه الثالثه وجزاكم الله خيرا مطلوب النقل.xlsm

اخ سليم بارك الله فيك وشكرا لاهتمامك المطلوب انى هختار اكتر من مره اريد الرقم الى هو بيثمل سعر اليوميه قيمه تثبت ويضاف عاليها القيمه الجديده وهكذا بمعنى انا اخترت يوميه ب100 ثم اخترت يوميه اخرى ب50 يعطينى اجمالى 150 وهكذا

الفكره انى عندى 30 يوم بتلاتين اختيار من القائمه المنسدله المطلوب عند اختيار اسم العامل من القائمه المنسدله يتم تسبيت المبلغ واضافه المبلغ الجديد على القديم فى كل اختيار لكن الى انا قدرت اوصله انه بيختار لمره وحده فقط ويمسح عند اختيار اليوم الثانى تكرمو عالينا بالمساعده اثابكم الله الاجور.xlsx

up

لايتم حفظ التغيرات فى كثيرا من الاوقات الزناتى للتجاره والتوزيع.xlsm

مطلوب طريقه عمل اكواد للاصناف مهما كان عددها وطريقه استدعائها فى اى شيت من الشيتات او كيف يتم الربط بين الكود واسم الصنف ولكم جزيل الشكر تكويد الاصناف.xlsx

استاذنا الفاضل سليم حاصبيا نرجو منك ان تشرح لنا هذا الكود وهو احدى ابداعاتك لكى نتعلم منك نفعك الله بهذا العلم وجعله من العلم الذى تنتفع به يا اخى Option Explicit Sub Add_sheet() Dim myname As Worksheet Dim P As Worksheet Dim sh_n%, k%, i% Set P = Sheets("اليوميه") sh_n = Application.CountA(P.Range("B:B")) - 1 Dim x%, t%: t = 2 Dim mn$ Application.ScreenUpdating = False ''''''''''''''''''''''''''''''''''''''''' For i = 2 To sh_n On Error Resume Next mn = Sheets(P.Range("b" & i) & "").Name x = Len(mn) If x = 0 Then P.Copy after:=Sheets(Sheets.Count) With ActiveSheet .Name = P.Range("b" & i) .Range("G14") = P.Range("F" & i) .Range("a1").CurrentRegion.Offset(1).ClearContents .Range("A:A").NumberFormat = ("dd- mm-yyy") For k = 2 To sh_n + 1 If P.Range("b" & k) = ActiveSheet.Name Then ActiveSheet.Cells(t, 1).Resize(, 4).Value = _ P.Range("A" & k).Resize(, 4).Value t = t + 1 End If Next End With '========================================= Else Set myname = Sheets(P.Range("b" & i) & "") myname.Range("a1").CurrentRegion.Offset(1).ClearContents For k = 2 To sh_n + 1 If P.Range("b" & k) = myname.Name Then myname.Cells(t, 1).Resize(, 4).Value = _ P.Range("A" & k).Resize(, 4).Value t = t + 1 End If Next '''''''''''''''''''''''''''''''''''' End If mn = "" Err.Number = 0 t = 2 Next i P.Select Application.ScreenUpdating = True End Sub tarhil_by_names.xlsm

ماذا تعنى رساله الخطاء هذه ولما يعلق زر design mode وطريقه الحل لكل صوره من الصوره التى تحمل رساله الخطاء التى قمت برفعها ارجو بالترتيب لكى افهم

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

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

بردو بيختفى على العموم شكرا اخى ابو تامر والشكر موصول للاخ سليم على المحاوله والاهتمام