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

جرب المرفق التالي ................ Database1 (15).accdb

السلام عليكم اتفضل اخى @محمد احمد لطفى DELETE Table1.id FROM Table1 WHERE (((Table1.id) In (SELECT DISTINCT Table2.id FROM Table2; ))); بالتوفيق Delt_1.mdb

حسب فهمي DoCmd.OpenForm "إضافة شحنة", , , "[كود_الشحنة]=" & Me.كود_الشحنة, , acDialog الملف مرفق تجريبي.accdb

آمين ولك بمثل ما دعوت واكثر وأحبك الله الذي احببتنا فيه

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

فحص لكلامي: Sub TestPeriods() Dim DateFm As Date Dim DateTo As Date DateFm = DateSerial(1583, 1, 1) DateTo = DateSerial(9999, 12, 31) Debug.Print GetYears(DateFm, DateTo) Debug.Print (DateTo - DateFm + 1) / 365.25 Debug.Print (DateTo - DateFm + 1) / 365.2425 End Sub النتائج 8417 8416.82683093771 8416.99966460639

واياكم اخى محمد انت نسخت الظاهر فالمعيار اضغط كليك يمين على المعيار واختار انشاء ليفتح لك منشىء التعبير وسوف يظهر لك كامل وها هو ع سطر واحد In (SELECT DISTINCT Table2.id FROM Table2;) بالتوفيق

أستاذى @ابوبسمله جزاك الله كل خيراً عند اخذ الامر ووضعه فى برنامجى ينقضه قوس In (SELECT DISTINCT Table2.id وعند العمل على الكود DELETE Table1.id FROM Table1 WHERE (((Table1.id) In (SELECT DISTINCT Table2.id FROM Table2; ))); يعمل تمام أريد أين الخطأ فى السطر الاول لكى أفهم الكود

@kanory الف شكر لك اخي الكريم فعلا هذا المطلوب @محمد احمد لطفىشكرا لك اخي العزيز على المساعده ايضا

لقد اتشر هذا المبدأ فى الاونة الأخيرة وتتبناه العديد من الشركات و هو يطلق عليه Low Code No Code Platforms أي أن معد البرنامج لا ينبغي ان يكون مبرمجا ، و لكن يستخدم الاداوات المتاحة فى التطبيق و قد تبني معهد ادارة المشاريع مبادرة Citizen Developper ، و يمكنك قراءة المزيد عنها هنا https://www.pmi.org/citizen-developer/ وهذا المقال بضيم بعض الأمثلة علي بعض التطبيقات المشار اليها https://www.trio.dev/blog/low-code-platforms

طول الخط مافكرت اضع شرط عند فتح النموذج...كان كل تفكيري ان لا اغير في الكود

هذا بسبب استخدام FindRecord ولا احبذ استخدامه لكن لو جدلا اردنا استخدامها يكون بالشكل الاتى Private Sub كود_شحنة_Click() Dim stDocName As String Dim stLinkCriteria As String stDocName = "إضافة شحنة" stLinkCriteria = "[كود_الشحنة]=" & Me![كود_الشحنة] DoCmd.OpenForm stDocName, , , stLinkCriteria, , acDialog 'Call [Form_إضافة شحنة].SetFocus ' 'DoEvents End Sub

الله يعلم اني كنت اردت ان اعطيكم اثنينكم ولكن الموقع يسمح لشخص فقط وهذا لطفا منك اخي @Ahmed_J وحق @AbuuAhmed محفوظ عندي وعند الله اذا في مجال تتعدل عدلها لاني ما اعرف كيف

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

اهي النقطة اللي محيرتني .. يعني مثلا العميل اشتغل لمدة على نواة 32.. وبعد مدة اراد العمل على 64..طيب هو القاعدة الخلفية مشتركة بين الاثنين ولا ايه؟

بعد اذن استاذي @ابو جودي استخدم نفس الكود عندك في حدث GotFocus واجعل modal=yes للنموذج (اضافة شحنة)

The results will be populated to the suitable number of columns so you can't modify the number of columns in results. Try to put more names and values and you will see the output will be populated in more than five columns

وعليكم السلام ورحمه الله وبركاته تفضل هذا الكود ( تعديل لكودك ) Sub ترحيل_البيانات() Dim Lr As Long, SH As Worksheet, WS As Worksheet Set SH = ThisWorkbook.Worksheets("تقرير الوردية اليومي") Set WS = ThisWorkbook.Worksheets("شيت مجمع") Application.ScreenUpdating = False If MsgBox("انت تريد ترحيل هذا الايصال . هل تريد الاستمرار ؟", vbYesNo + vbQuestion) = vbNo Then Exit Sub End If If SH.Cells(4, 3).Value <> "" Then With SH .Activate .Unprotect Password:="011005051002018" WS.Unprotect Password:="011005051002018" If WS.FilterMode Then WS.ShowAllData End If Lr = WS.Cells(Rows.Count, "G").End(xlUp).Row + 1 WS.Range("A" & Lr).Resize(4) = .Range("C4").Value WS.Range("A" & Lr).Resize(4).NumberFormat = "dd/mm/yyyy" WS.Range("B" & Lr).Resize(4) = .Range("E4").Value WS.Range("C" & Lr).Resize(4) = .Range("G4").Value WS.Range("D" & Lr).Resize(4) = .Range("I4").Value WS.Range("E" & Lr).Resize(4) = .Range("K4").Value WS.Range("F" & Lr).Resize(4) = .Range("N4").Value .Range("B7:M10").Copy WS.Range("G" & WS.Cells(Rows.Count, "G").End(xlUp).Row + 1).PasteSpecial xlPasteValues .Range("B13:P16").Copy WS.Range("S" & WS.Cells(Rows.Count, "S").End(xlUp).Row + 1).PasteSpecial xlPasteValues .Range("C4,G4,I4,K4,N4,D7:J10,L7:P10,D13:I16,L13:P16").ClearContents .Protect Password:="011005051002018", AllowFiltering:=True, AllowFormattingCells:=True Application.Goto WS.Range("C4") WS.Protect Password:="011005051002018", AllowFiltering:=True, AllowFormattingCells:=True End With Else MsgBox "الرجاء وضع التاريخ و ملئ البيانات" SH.Activate SH.Range("C4").Select Exit Sub End If Application.ScreenUpdating = True End Sub

شوفت اخوي محمد لما رفعت البيانات كاملة امكنني فحص الخلل وعلاجه مازال تاريخ التسديد ناقص 2000 سجل ولكني اعتمدت تاريخ الأذن المشكلة من النظام نفسه لا يسمح باكثر من 9500 سجل التي هي القيمة الافتراضية لذا يجب تعديلها بهذا السطر DAO.DBEngine.SetOption dbMaxLocksPerFile, 45000 انا جعلتها 45000 يمكنك انقاص الرقم او زيادته ليصبح الكود هكذا : Dim rs As DAO.Recordset Dim i As Long Dim x As Integer Dim r As String DAO.DBEngine.SetOption dbMaxLocksPerFile, 45000 Set rs = CurrentDb.OpenRecordset("SELECT Sheet1.cod, Sheet1.num , Sheet1.date_ezen fROM Sheet1 ORDER BY Sheet1.nname,Sheet1.cod , Sheet1.date_ezen ") If rs.RecordCount > 0 Then rs.MoveLast rs.MoveFirst Else Exit Sub End If r = rs!cod x = 1 For i = 1 To rs.RecordCount rs.Edit If rs!cod = r Then rs!num = x x = x + 1 Else x = 1 r = rs!cod rs!num = x x = x + 1 End If rs.Update rs.MoveNext Next rs.Close: Set rs = Nothing تفضل المثال بعد التعديل افتح الاستعلام بعد عملية الترقيم لترى النتيجة

جرب هذا الكود Private Sub Command16_Click() Dim invRst As Recordset Dim itmRst As Recordset If vbNo = MsgBox("هل تريد حذف الفاتورة الحاليه ؟؟؟", vbYesNo + _ vbCritical + _ vbMsgBoxRight + _ vbDefaultButton2, "تحذير") Then Exit Sub End If Set itmRst = CurrentDb.OpenRecordset("Stor1", dbOpenDynaset) Set invRst = Me.frmPurches.Form.RecordsetClone invRst.Filter = "Add_doc=" & Me.Add_doc Set invRst = invRst.OpenRecordset With invRst invRst.MoveFirst Do While Not .EOF itmRst.FindFirst "Number1='" & !Number & "'" If Not .NoMatch Then itmRst.Edit itmRst!currentRased1 = itmRst!currentRased1 - !Qty_in itmRst.Update End If .MoveNext Loop End With Set invRst = Nothing Set itmRst = Nothing End Sub

بالعكس ..نحن هنا لخدمة الجميع .. ودعائك افضل بكثير مما نقدمه ...

ممنون منك اخي العزيز تعتك و ياي رحم الله و الديك شكرأ لك اخي الكريم على النصيحة موفق ان شاء الله

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

تمام هذا مخرج لمن يواجه المشكلة بالنسبة لقاعدت البيانات التي لدي لا مشكلة عندي ان ارسلها بصيغة accdb لو الذي سيعمل عليها محترف ولكن من باب الحماية من العبث او الخلل غير المقصود وبالنسبة لامتداد accdr عمل بكل سلاسة على 64 .. الف شكر اخي العزيز ابو بسملة .

وجدتهااااااااااااااا ^_^ Dim Sn As Integer Dim aD As Integer For Sn = 1 To 31 aD = Sn - 1 Me("txtD" & Format(Sn, "00")) = Format(txtTodyDate + aD, "dd - mm") Me("txtDN" & Format(Sn, "00")) = Format(txtTodyDate + aD, "ddd") Next Sn

في حدث فتح التقرير أضفت لك سطر التركيز على صندوق نص البحث Private Sub cmd_Print_rpt_Click() Me.txtsearch.SetFocus DoCmd.OpenReport "Report0", acViewPreview End Sub

Try this code Sub Test_LionHeart() Dim a, b, lr As Long With ActiveSheet lr = .Cells(Rows.Count, 1).End(xlUp).Row .Range("D2:H" & lr).ClearContents a = CreateNamesArray(.Range("A2:A" & lr), .Range("B2:B" & lr)) ShuffleArray a b = ConvertToColumns(a, lr - 1) .Range("D2").Resize(UBound(b, 1), UBound(b, 2)).Value = b End With End Sub Function CreateNamesArray(ByVal namesRange As Range, ByVal countRange As Range) Dim nameArray, nameIndex As Long, countIndex As Long, rowCount As Long, totalNames As Long, currCount As Long, i As Long rowCount = namesRange.Rows.Count totalNames = WorksheetFunction.Sum(countRange) ReDim nameArray(1 To totalNames, 1 To 1) nameIndex = 1 For countIndex = 1 To rowCount currCount = countRange(countIndex, 1).Value For i = 1 To currCount nameArray(nameIndex, 1) = namesRange(countIndex, 1).Value nameIndex = nameIndex + 1 Next i Next countIndex CreateNamesArray = nameArray End Function Private Sub ShuffleArray(ByRef arr) Dim temp, i As Long, j As Long Randomize For i = LBound(arr) To UBound(arr) j = Int((UBound(arr) - i + 1) * Rnd + i) temp = arr(i, 1) arr(i, 1) = arr(j, 1) arr(j, 1) = temp Next i End Sub Function ConvertToColumns(ByVal inputArray, ByVal divisor As Long) Dim numOutputCols As Long, i As Long, j As Long, k As Long numOutputCols = Application.WorksheetFunction.RoundUp(UBound(inputArray, 1) / divisor, 0) ReDim outputArray(1 To divisor, 1 To numOutputCols) k = 1 For j = 1 To numOutputCols For i = 1 To divisor If k <= UBound(inputArray, 1) Then outputArray(i, j) = inputArray(k, 1) k = k + 1 End If Next i Next j ConvertToColumns = outputArray End Function

السلام عليكم ورحمه الله وبركاته اتفضل اطلع المشاركه التاليه لاخى واستاذى العزيز @kanory جزاه الله عنا كل خير بالتوفيق

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

تفضل اخي Private Sub Worksheet_Change(ByVal Target As Range) Dim WRng As Range, WRng2 As Range Dim rg As Range, rg2 As Range Dim ST1 As Integer, ST2 As Integer Set WRng = Intersect(Application.ActiveSheet.Range("B8:B1000"), Target) Set WRng2 = Intersect(Application.ActiveSheet.Range("d8:d1000"), Target) On Error Resume Next ST1 = 1 ST2 = 1 If Not WRng Is Nothing Then Application.EnableEvents = False For Each rg In WRng If Not VBA.IsEmpty(rg.Value) Then rg.Offset(0, ST1).Value = Now rg.Offset(0, ST1).NumberFormat = "dd-mm-yyyy HH:mm" Else rg.Offset(0, ST1).ClearContents End If Next Application.EnableEvents = True End If If Not WRng2 Is Nothing Then Application.EnableEvents = False For Each rg2 In WRng2 If Not VBA.IsEmpty(rg2.Value) Then rg2.Offset(0, ST2).Value = Now rg2.Offset(0, ST2).NumberFormat = "dd-mm-yyyy HH:mm" Else rg2.Offset(0, ST2).ClearContents End If Next Application.EnableEvents = True End If End Sub مسحوبات الخطوط.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته ..تفضل اخي تم اضافة كود الفاتورة للصفحات الاربعة AA.xlsm

السلام عليكم ورحمة الله وبركاته 📜برنامج المخزون والفواتير الشامل الإصدار الرابع 2020 البرنامج هو تحديث للاصدارات السابقة من نفس البرنامج اولا وقبل كل شيئ اعتذر عن التأخير فى اطلاق هذا الاصدار نظرا لانشغالي الدائم وظروف خارجه عن الارادة. كما هو معروف عن برنامج المخزون و الفواتير الشامل: واجهة تطبيقية كاملة علي الاكسيل يصلح لكافة اغراض المبيعات و المشتريات وذمم عملاء وموردين و حساب المصروفات مع ميزانية عامه توضح الربح و الخساره. البرنامج مليئ بافكار جديده فى طريقة ادخال الاصناف داخل الفواتير و استدعائها و التعديل عليها.بالاضافه الي طرق جديده فى تصميم الفاتورة كما يتميز البرنامج بكثرة التقارير وسهولة الحصول عليها فى اى وقت يعمل علي جميع اصدارات الاكسيل بنواتين 32 أو 64 بت ويفضل دائما الاصدارات الاحدث من الاكسيل اوفيس 2019 و 365 البرنامج مجاني بنسبة 100 % للاستخدام الشخصي ولا يوجد به تاريخ انتهاء. وتستطيع استخدامه بامان تام.ويمنع بيع البرنامج او اي ربح تجاري بدون الرجوع الي المالك الاصلي.و الله الشاهد علي ذلك. تم تصميم البرنامج بمواصفات خاصه ويعمل للشركات الصغيره الي متوسطة الحجم او للمشاريع الخاصه .وهو فى الاصل برنامج تجارى ولكنى اقدمه هنا للمنتدى وللأخوة الاعضاء بصورة مجانية. تم اطلاق الاصدار الاول من هذا البرنامج عام 2012.وكل ما يلزم هو وجود نسخة اكسيل علي جهازك.وسيفي بالغرض تماما. هذا هو اخر اصدار للبرنامج علي اكسيل و الاصدار الخامس و لمزيد من التحسينات الكبيره سوف يتم تطويره إن شاء الله بلغة برمجه اخري وقاعده بيانات اخري. الدخول الاول:اسم المستخدم "مدير" و الباسورد 123 تم ارفاق نسختين من البرنامج نسخة الاستخدام المباشر كمستخدم ويمكنك استخدامها فى عملك مباشرة. نسخة اخري للتعلم مفتوحة المصدر وتوجد بها جميع الاكواد لجميع الشاشات داخل البرنامج للتعلم او التعديل عليها كما هو الغرض الرئيسي من هذا الصرح العظيم. يمكنك الرجوع الي الاصدارات السابقة حيث يوجد شرح كامل لكيفية استخدام البرنامج لاول مرة. توجد الروابط للاصدارات السابقة و الشرح اسفل هذا الموضوع . 📑الجديد في هذا الاصدار (2020)SIS Ver.4: شاشة تصميم الفواتير و هي من الشاشات الجديدة وبها الكثير من الاكواد الجديده فى الاكسيل (علي حسب علمي) حيث تمكنك من وضع اللوجو الخاص بالمؤسسه او الشركة الخاصه بك كما يمكنك ايضا وضع بياناتك اسفل الفاتورة كرقم التليقون و العنوان و ...... التحكم الكامل في بعض القيم و ظهورها داخل الفاتورة كرصيد العميل. شاشة اختيار عملة الدولة ووضع الضريبه او القيمه المضافه تمكنك هذه الشاشه من اختيار العمله علي حسب الدوله التي تعمل فيها. كما تمكنك من ضبط قيمة الضريبه او القيمه المضافه لفواتيرك شاشة ضبط صلاحيات المستخدمين بعد اضافة مستخدم جديد للبرنامج تستطيع ضبط صلاحيات المستخدم من الوصول الي جميع شاشات البرنامج شاشة حذف البيانات الغير مستخدمة بكل سهولة تستطيع حذف العملاء و الموردين او الاصناف الغير مستخدمة داخل البرنامج. شاشة الحركة المالية السريعة تستطيع ادخال سند صرف موردين او سند عميل بضغطة زر واحده. شاشة الفواتير الكثير من التحسينات تم ادارجها داخل شاشة الفواتير فاتورة المشتريات . انت من يقوم بوضع رقم الفاتورة الخاصه من المورد.بدلا من وضعها اتوماتيكيا كالاصدار السابق. اضافة خصم اجمالي علي الفاتورة. يتم تحديد الخصم كنسبه مئويه او خصم مبلغ مقطوع. اضافة الضريبه علي الفاتورة ويمكن تحديد قيمتها يدويا او تثبيتها من خلال شاشة البيانات الجديده وضبط الضريبه او القيمه المضافه علي حسب الدولة. مبيعات نقدي: فى حالة اختيار هذا النوع من الفواتير يتم ادراج سند قبض مباشره الي حساب العميل مع حفظ الفاتورة لانها مبيعات نقدية. ظهور رصيد العميل الحالي داخل الفاتورة. و التحكم في ظهوره من خلال شاشة تصميم الفاتورة. زر لسداد كامل الفاتورة مباشرة وادراج سند قبض او سند صرف داخل حساب العميل/المورد سند بالمبلغ المدفوع داخل الفاتورة وتسوية حساب العميل او المورد. شاشة الحركات المالية ادراج الكثير من الحركات المالية داخل سند الصرف. شاشة جديده لحساب رواتب وجميع الحسابات للموظفين العاملين فى المؤسسة او الشركة يوجد الكثير من الاضافات و التحسينات علي كل الشاشات والتقارير داخل البرنامج . تستطيع اكتشاف المزيد و المزيد اثناء استخدام البرنامج. التعامل مع رصيد اول المده (كميات الاصناف- حسابات العملاء/الموردين) تم الاستغناء عن شاشة اكواد البيانات والجرد فى هذا الاصدار وكانت تستخدم لوضع رصيد اول المده للاصناف. وعوضا عن ذلك ولحساب المخزون بطريقه منظمه يجب ان يتم وضع كميات اول المده لجميع الاصناف من خلال فاتورة مشتريات باسعار شراء محدده حتي يتم ادراجها وحسابها بطريقه دقيقه.وايضا فى حالة رصيد سابق للعملاء والموردين يجب ان يتم ادخاله من خلال شاشة الحركات الماليه( حركة ماليه رصيد اول مده او ترحيل لحساب عميل/مورد) طباعة الباركود لا تزال غير مفعله ايضا فى هذا الاصدار. 👁️‍🗨️شرح كيفية استخدام البرنامج وادخال البيانات من الاصدارت السابقة:(برجاء مراجعة الروابط التالية) شرح برنامج المخزون و الفواتير الشامل(مشاركة داخل المنتدى) استخدام البرنامج لاول مره من الاصدار الثالث شرح برنامج المخزون و الفواتير الشامل( ملف تنفيذى... 6MB رابط خارجى على موقع ميديا فاير) 🏷️تحميل البرنامج: النسخة الاولي SIS 4.566EO : هى نسخة المستخدم النهائي مجانيه 100 % لاعضاء المنتدي الكرام وليس لها تاريخ انتهاء وكما ذكر سابقا هي للاستخدام الشخصي فقط. 💳SIS 4.566EO.rar النسخة الثانيه SIS 4 Learning : هي نسخة للمطورين و الباحثين عن التعلم وهي نسخة مفتوحة المصدر تحتوي علي جميع اكواد الشاشات داخل البرنامج. 🧼SIS4(Learning).rar إن شاء الله سوف اقوم بالرد علي استفسارات اعضائنا الكرام عندما يتوفر لي الوقت و اعتذر مقدما عن اي تاخير نظرا لانشغالي الدائم. اخيرا أحب انا أشكر جميع مشرفي و اعضاء هذا الصرح العظيم. واتمني من الله ان يكون هذا العمل خالصا لوجه الله سبحانه و تعالي و انا اكون قد قدمت تجربه جيده لهذا النوع من البرامج علي الاكسيل وان ينفع به جميع اعضاء المنتدي الكرام

تفضل أستاذى وايضا يمكنك زيادة ما شئت من الصفوف بنفسك من قبل صف الإجمالى شيت فاضى.xlsx

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

السلام عليكم ورحمة الله وبركاته قائمة Validation مختارة من نتيجة بحث في نفس خلية القائمة لا تحتاج الى ترتيب بيانات البحث وممكن استخدامها في اي ورقة من اوراق الملف المرفق 2003 بحث في خلايا قائمة التحقق من الصحة.rar

اكتب الصنف اضغط انتر ينتقل الى الكمية ادخل الكمية اضغط انتر يعود الى الصنف نموذج 2007.rar

الاخوه الافاضل السلام عليكم ورحمة الله وبركاته بناء على طلب الاخ طاهر محمد فى تنفيذ برنامج يصلح لجمعيه خيريه وقد تم بحمد الله عمل البرنامج بنجاح ................................................ ولكنى اردت فقط ان اطرح العمل فى موضوع جديد لتعم الاستفاده على من يريد ................................... اريد ان اعتزر على عرض الموضوع مرتين ولكن حدث خطأ فى رفع الملف فى المره الاولى التى تم عرض الموضوع فيها على الرابط الاتى http://www.officena.net/ib/index.php?showtopic=56548&hl= تقبلو تحياتى جمعية خيرية2.rar

رتب أسمائك أبجديا بمنتهى البساطة وبعيدا عن تعقيد الكود رتب أسمائك أبجديا بالمعادلات.rar

السلام عليكم أخي العزيز أهلا ومرحبا بك بين إخوانك كما قال أخونا أشرف (أبومحمد) الأفضل دائما إرفاق ملف يسهل علي من يريد المساعدة ولكن كتحية بك حيث هذه أول مشاركاتك ، تفضل المرفق قف بالماوس علي أي من الخلايا الملونة بالعمود I تلوين الموردين.rar

السلام عليكم جرب هذا الكود Sub ali_Sh() On Error Resume Next Dim Sh As Worksheet Dim Rn As Range With Application .ScreenUpdating = False .EnableEvents = False A = ActiveSheet.Name For Each Sh In ThisWorkbook.Worksheets With ActiveSheet For Each Rn In .Range("K3:K" & .Cells(Rows.Count, 11).End(xlUp).Row) If Rn = Sh.Name Then .Range("C" & Rn.Row).Copy Sh.Select Sh.Cells(Sh.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Row, "C").PasteSpecial xlPasteValues Sheets(A).Select End If Application.CutCopyMode = False Next End With Next .ScreenUpdating = True .EnableEvents = True End With End Sub Book1_A.rar

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

مرفق ملف يمكن الاستفادة منه ان شاء الله الملف من المنتدى ____.rar