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

وعليكم السلام -تفضل لك ما طلبت .. وكان لابد من رفع الملف بدون ضغط , طالما حجم الملف صغير وذلك تجنباً لإهدار الوقت وشكراً Aziz1.xlsx

تفضل Sub Copying_yellow_cells() Dim i As Long, j As Long For i = 5 To Range("f" & Rows.Count).End(xlUp).Row For j = 1 To Columns("H").Column If Cells(i, j).DisplayFormat.Interior.Color = vbYellow Then Cells(i, "H").Value = Cells(i, j).Value Exit For End If Next Next End Sub نسخ الخلايا الملونة في العمود B.xlsm

السلام عليكم ورحمة الله وبركاته لديا قاعدة بيانات بها منتجات ما اريده هو البحث والفلترة طبقا للمكتوب داخل مربع ال combo box اي تصفية النتائج طبقا لما هو مكتوب داخل الكومبو بوكس وشكرا جزيلا لمن يساعدني المساعدة في الكومبو بوكس.rar

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

تفضل جرب اخي ووافينا بالنتيجة Sub RefreshData() ' تعديل Dim i As Long, k As Long Dim last_Dest As Long, lastrow As Long Dim ws_data As Worksheet: Set ws_data = Worksheets("data") For Each ws_dest In ThisWorkbook.Worksheets lastrow = ws_data.Cells(ws_data.Rows.Count, 1).End(xlUp).row last_Dest = ws_dest.Cells(ws_dest.Rows.Count, 1).End(xlUp).row Application.ScreenUpdating = False For i = 2 To lastrow For k = 2 To last_Dest 'في حالة وجود اوراق اخرى على المصنف قم باظافتها هنا If ws_dest.Name <> ws_data.Name And ws_dest.Name <> "اليومية" And ws_dest.Name <> "ورقة6" Then ' شرط تطابق عمود التسلسل وعمود التوجيه If ws_dest.Cells(k, 1).Value = ws_data.Cells(i, 1).Value And _ ws_dest.Cells(k, 2).Value = ws_data.Cells(i, 2).Value Then _ 'في حالة تحقق الشرط ws_dest.Cells(k, 3).Value = ws_data.Cells(i, 3).Value 'التاريخ ws_dest.Cells(k, 4).Value = ws_data.Cells(i, 4).Value ' البيان ws_dest.Cells(k, 5).Value = ws_data.Cells(i, 5).Value 'مدين ws_dest.Cells(k, 6).Value = ws_data.Cells(i, 6).Value 'دائن ws_dest.Activate 'تسطير تلقائي للبيانات DL = ws_dest.Range("A65500").End(xlUp).row DC = ws_dest.Cells(1, Columns.Count).End(xlToLeft).Column ws_dest.Columns("A:F").Borders.LineStyle = xlNone ws_dest.Range(Cells(2, 6), Cells(DL, DC)).Borders.Weight = xlThin End If End If Next Next Next ws_dest ws_data.Activate MsgBox "تم التعديل بنجاح", 64 Application.ScreenUpdating = True End Sub Sub transfer_data() ' ترحيل Dim Sh As Worksheet Dim ws_data As Worksheet: Set ws_data = Worksheets("data") For Each Sh In ThisWorkbook.Worksheets For R = 2 To [B20000].End(xlUp).row If Cells(R, 2).Value = Sh.Name And Cells(R, 2).Value <> Empty Then Application.ScreenUpdating = False Cells(R, 2).Resize(1, 5).Copy Sh.Range("B" & Sh.[B20000].End(xlUp).row + 1) End If Next Next For Each Sh In Worksheets 'في حالة وجود اوراق اخرى على المصنف قم باظافتها هنا If Sh.Name <> "اليومية" And Sh.Name <> "data" And Sh.Name <> "ورقة6" Then Sh.Activate Sh.Range("A3:A1000").ClearContents Sh.Range("A3") = 1 Sh.Range("A3:A" & Range("B" & Rows.Count).End(xlUp).row).DataSeries , xlDataSeriesLinear DL = Sh.Range("A20000").End(xlUp).row DC = Sh.Cells(1, Columns.Count).End(xlToLeft).Column Sh.Columns("A:F").Borders.LineStyle = xlNone Sh.Range(Cells(2, 6), Cells(DL, DC)).Borders.Weight = xlThin End If Next MsgBox ("تم بحمد الله ترحيل القيود لا تنسى أن تشكر الله علي هذه النعم "), vbOKOnly + vbInformation, "لاتنسونا من صالح الدعاء لنا ولولدينا وللمسلمين" ws_data.Activate Application.ScreenUpdating = True End Sub استدعاء من عدة شيتات- V3.xlsm

ملاحظاتي :- 1- ليش غالق محرر الأكواد ؟؟؟؟؟ مع أني فتحته . 2- العمليات الحسابية تتم بالحداول أو بالاستعلامات او بالنماذج ويتم عرضها بالتقارير . 3-تقريرك لا يمت لما طلبته بصله لأنك لم تحدد مصدره من أي جدول. حدد طلبك ويش تريد من البرنامج يسوي . وخلي التقرير أخر شيء.

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

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

وعليكم السلام ورحمة الله 🙂 ممكن تعمل حقل عبارة عن قائمة منسدلة بها الـ 3 خيارات اللي ذكرتها (موافق - غير موافق - للتريث ) .. وتكون ظاهرة للمدير فقط .. ويمكنك أن تفلتر السجلات عليها ..

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

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

بارك الله فيك اخي @Moosak وجعلها الله في ميزان حسناتك ان شاء الله ونفع بك

لتعديل البيانات لابد من وضع شرط ثابت يمكننا الاعتماد عليه داخل الاكواد وهدا غير متوفر عندك على الملف بحكم ان البيانات في العمود الاول والثاني مكررة في عده صفوف في وجهة نظري افضل طريقة هي استبدال كود الترحيل والاشتغال على انشاء اوراق عمل بشرط القيم الموجودة في عمود التوجيه مع حدف الاوراق السابقة بحيث يتم تحديث جميع اوراق العمل سواءا عند اظافة جديدة او تعديل . هدا ما فهمت من ملفك لحد الساعة . يمكنك توضيح الامر اكثر في حالة ان هدا الحل لا يناسبك. Sub RefreshData() Dim cUnique As Collection Dim rng As Range, cRng As Range Dim Cell As Range, LstRow As Long Dim W_Name As Variant, s As String Dim worksheetexists As Boolean Set WS_Data = ThisWorkbook.Sheets("data") ' الرئيسية Set ST2 = ThisWorkbook.Sheets("اليومية") Set rng = WS_Data.Range("A3:A" & WS_Data.Cells(WS_Data.Rows.Count, "A").End(xlUp).Row) Set cUnique = New Collection Application.ScreenUpdating = False Application.DisplayAlerts = False For Each ws In Sheets If ws.Name <> WS_Data.Name And ws.Name <> ST2.Name Then ws.Delete Next On Error Resume Next For Each Cell In rng.Cells cUnique.Add Cell.Value, CStr(Cell.Value) Next Cell On Error GoTo 0 For Each W_Name In cUnique s = W_Name Sheets.Add(After:=Sheets(Sheets.Count)).Name = W_Name ActiveSheet.DisplayRightToLeft = True With WS_Data LstRow = .Cells(.Rows.Count, "A").End(xlUp).Row .Range("A2").AutoFilter Field:=1, Criteria1:=W_Name Set cRng = .Range("A2:E" & LstRow) cRng.Copy Sheets(s).Range("A2") .Select .Range("A2").AutoFilter ST2.Move After:=Worksheets(Worksheets.Count) End With For Each ws In Sheets If ws.Name <> WS_Data.Name And ws.Name <> ST2.Name Then ws.Columns("A:E").ColumnWidth = 21 Next Next W_Name Application.ScreenUpdating = True WS_Data.Activate End Sub استدعاء من عدة شيتات V2.xlsm

البرنامج محول إلى الصيغة accde .. لايمكن فتحه .. يجب أن ترجع للمصمم الأصلي للبرنامج وتطلب البرنامج بصيغة accdb

تعديل على ملف الأستاذ @kkhalifa1960 🙂 جرب الآن الملف .. ( قبل وبعدما تقسمه ) attention.rar

جزاك الله خيرا ذكرتنى ببرنامج لى قديم استخدمت فيه هذه الملفات أو مثلها Holy_Quran.rar