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

أرجو ان يكون هذا ما تريد جرب ووافنا بالنتائج TestMessage.accdb

كان عليك استخدام خاصية البحث بالمنتدى - تفضل كيفية كتابة الأس في إكسل أو هذا الرابط طريقة كتابة الأس في إكسل Excel وهذا فيديو أيضاً للتوضيح

اذا جرب هذا DATA20007.rar

الملف من جديد مع اختيار التاريخ من الى في الحلايا L2 و M2 في حال الخطأ بكتابة التواريخ في L2 او M2 او ادراح تواريخ غير موجودة في البيانات يقوم الماكرو بادراج كل التواريخ من اصغرها الى اكبرها اذا كنت تريد يوما واجداً اجعل L2 و M2 متساويتين (مثلا لاختيار 10 ابريل اكتب 10/4/2021 في L2 و M2) Option Explicit Sub All_In_One() Dim SH(), itm, My_sh As Worksheet Dim T As Worksheet Dim Sb#, Sc#, Sd#, Se#, Sf#, Sg# Dim ads%, k%, n%, Ro%, Max_row% Dim X As Date Dim Dat1 As Date, Dat2 As Date Dim F_rg As Range, Wat Set T = Sheets("Total") Max_row = Sheets("Reg1").Cells(Rows.Count, 1).End(3).Row If Not IsDate(T.Range("L2")) Or _ IsError(Application.Match(T.Range("L2"), _ Sheets("Reg1").Range("A3:A" & Max_row), 0)) Or _ IsError(Application.Match(T.Range("M2"), _ Sheets("Reg1").Range("A3:A" & Max_row), 0)) Then Dat1 = Application.Min(Sheets("Reg1").Range("A3:A" & Max_row)) Dat2 = Application.Max(Sheets("Reg1").Range("A3:A" & Max_row)) T.Range("L2") = Dat1: T.Range("M2") = Dat2 Else Dat1 = Application.Min(T.Range("L2"), T.Range("M2")) Dat2 = Application.Max(T.Range("L2"), T.Range("M2")) T.Range("L2") = Dat1: T.Range("M2") = Dat2 End If k = T.Cells(Rows.Count, 1).End(3).Row If k < 3 Then Exit Sub T.Range("A3").Resize(k - 2, 7).ClearContents SH = Array("Reg1", "Reg2", "Reg3", "Reg4", "Reg5") For X = Dat1 To Dat2 T.Range("A3").Offset(n) = Dat1 + n n = n + 1 Next k = T.Cells(Rows.Count, 1).End(3).Row For n = 3 To k Wat = T.Range("A" & n) For Each itm In SH Set My_sh = Sheets(itm) Ro = My_sh.Cells(Rows.Count, 1).End(3).Row If Ro < 3 Then GoTo Next_Itm Set F_rg = My_sh.Range("A2:A" & Ro).Find(Wat, Lookat:=1) If F_rg Is Nothing Then GoTo Next_Itm ads = F_rg.Row Sb = Sb + Val(My_sh.Cells(ads, "B")) Sc = Sc + Val(My_sh.Cells(ads, "C")) Sd = Sd + Val(My_sh.Cells(ads, "D")) Se = Se + Val(My_sh.Cells(ads, "E")) Sf = Sf + Val(My_sh.Cells(ads, "F")) Sg = Sg + Val(My_sh.Cells(ads, "G")) Next_Itm: Next itm With T.Cells(n, 2) .Value = Sb: Sb = 0 .Offset(, 1) = Sc: Sc = 0 .Offset(, 2) = Sd: Sd = 0 .Offset(, 3) = Se: Se = 0 .Offset(, 4) = Sf: Sf = 0 .Offset(, 5) = Sg: Sg = 0 End With Next n End Sub الملف من جديد Hasan_Choise.xlsm

اها بسبب ان السجل غير محفوظ تفضل التعديل DoCmd.RunCommand acCmdSaveRecord DATA20006.rar

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

اتفضل هذا التعديل ما راح يقبل رقم فاتورة مكررة DATA20005.rar

السلام عليكم فضلا انظر المرفق مع الشكر نزار دالة الوقت.xls

وعليكم السلام ارفع من فضلك ملف مدعوم بشرح كافى عن المطلوب فلا يمكن العمل على التخمين !!!!

عليكم السلام والرحمة تفضل التعديل ارجو ان يكون طلبك ملاحظة : الكود يراعي يومي السبت والاحد فقط كعطل رسمية اما بقية العطل فيجب تحديدها وبعد معرفة كفاءة الكود يتم تعديل الكود على اساسها Reorder.rar

تم تعديل اسماء الضفحات الى Reg اي Region وذلك من اجل حسن نسخ الكود ولصقه دون مشاكل اللغة العربية وطهور أحرف غريبة فيه فقط اضغط الزر Run Option Explicit Sub All_In_One() Dim SH(), itm, My_sh As Worksheet Dim T As Worksheet Dim Ro%, Sb#, Sc#, Sd#, Se#, Sf#, Sg#, k%, n% Dim ads% Dim F_rg As Range, Wat Set T = Sheets("Total") k = T.Cells(Rows.Count, 1).End(3).Row If k < 3 Then Exit Sub T.Range("B3").Resize(k - 2, 6).ClearContents SH = Array("Reg1", "Reg2", "Reg3", "Reg4", "Reg5") For n = 3 To k Wat = T.Range("A" & n) For Each itm In SH Set My_sh = Sheets(itm) Ro = My_sh.Cells(Rows.Count, 1).End(3).Row If Ro < 3 Then GoTo Next_Itm Set F_rg = My_sh.Range("A2:A" & Ro).Find(Wat, Lookat:=1) If F_rg Is Nothing Then GoTo Next_Itm ads = F_rg.Row Sb = Sb + Val(My_sh.Cells(ads, "B")) Sc = Sc + Val(My_sh.Cells(ads, "C")) Sd = Sd + Val(My_sh.Cells(ads, "D")) Se = Se + Val(My_sh.Cells(ads, "E")) Sf = Sf + Val(My_sh.Cells(ads, "F")) Sg = Sg + Val(My_sh.Cells(ads, "G")) Next_Itm: Next itm With T.Cells(n, 2) .Value = Sb: Sb = 0 .Offset(, 1) = Sc: Sc = 0 .Offset(, 2) = Sd: Sd = 0 .Offset(, 3) = Se: Se = 0 .Offset(, 4) = Sf: Sf = 0 .Offset(, 5) = Sg: Sg = 0 End With Next n End Sub الملف مرفق Hasan.xlsm

جرب هذا جمع كودين.xlsm

تم تغيير تنسيق التاريخ في العموديين فقط مواقع استخدام العناصر 2021 - Copy (1).xlsm

هذه تجربة بحت من خلال فورم بنك.xlsm

Private Sub Workbook_Open() Application.ExecuteExcel4Macro "Show.toolbar(""ribbon"",false)" Application.DisplayStatusBar = False ActiveWindow.DisplayWorkbookTabs = False End Sub عليكم السلام ضع هذا الكود فى ملف العمل الخاص بك و اذا اردت اظهار شريط الادوات و شريط الحالة قم بتغير False الى True

ربما تحناح الى هذا الملف (النتيجة في الصفحة ALL) Sub Filter_All() Dim sh As Worksheet Dim A As Worksheet Dim AR_comp() Dim Ro%, K%, x%, t%, I% With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Set sh = Sheets("2021-3") Set A = Sheets("ALL") Set RG_Filter = sh.Range("B8").CurrentRegion If sh.AutoFilterMode Then RG_Filter.AutoFilter A.Range("A10:R1000").Clear Ro = RG_Filter.Rows.Count AR_comp = Array("شركة", "بنك مصر", "معاش") t = 10 For I = LBound(AR_comp) To UBound(AR_comp) RG_Filter.AutoFilter 4, AR_comp(I) RG_Filter.Cells(2, 1).Resize(Ro - 1, 18) _ .SpecialCells(12).Copy With A .Range("A" & t).PasteSpecial (8) .Range("A" & t).PasteSpecial (12) x = _ .Cells(Rows.Count, 1).End(3).Row + 1 .Cells(x, 1) = "Sum" .Cells(x, "G").Resize(, 12).Formula = _ "=SUM(G" & t & ":G" & x - 1 & ")" .Cells(x, 1).Resize(, 6).HorizontalAlignment = 7 .Cells(x, 1).Resize(, 18).Interior.ColorIndex = 35 t = x + 1 End With Next I If t = 10 Then GoTo End_me With A.Cells(t, 1) .Value = "TOTAL SUM :" .Resize(, 6).HorizontalAlignment = 7 .Resize(, 18).Interior.ColorIndex = 40 .Offset(, 6).Resize(, 12).Formula = _ "=SUM(G10:G" & t - 1 & ")/2" End With With A.Range("A10").CurrentRegion .Borders.LineStyle = 1 .Font.Size = 14 .Font.Bold = True .Value = .Value End With End_me: If sh.AutoFilterMode Then RG_Filter.AutoFilter With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .CutCopyMode = False End With A.Activate Range("A10").Select End Sub الملف مرفق Nafal_1.xlsm

وعليكم السلام -أهلاً بك فى منتدانا , يمكنك استخدام هذه المعادلة لتلبية طلبك =SUMPRODUCT(SUMIF(INDIRECT("'"&$B9&"'!"&"C9:C19"),C$7,INDIRECT("'"&$B9&"'!"&"D9:D19"))) Boo2.xlsx

السلام عليكم يمكن هذى الى ترغب فيه بالتوفيق إن شاء الله 123456.rar

السلام عليكم اخى الفاضل الملف الذى قمت برفعة هو عبارة عن صورة وتم تحويلها الى ملف PDF لذا فانة من الصعب تحويل الملف الى اكسيل بنفس التنسيق ولكن اذا كان الملف هو فى الاساس اكسيل او وررد و تم تحويلة الى PDF فانة من الممكن تحويل الملف مرة اخرى الى اكسيل مرفق ملف من عمل احد الاخوة فى الموقع يكمن من خلالة تحويل PDF الى اكسيل PDF to Excel Converter.xlsm

اليكم رابط برنامج عواصم العالم والدول كاملا اصدار رقم 1 https://top4top.io/downloadf-1654wznys1-rar.html ارجو ان ينال اعجابكم وهو يعتبر متكامل لجميع دول العالم وعواصمها واعلامها والقارة التى تقع فيها كل دولة ومستعد لتلقى اى ملاحظات للتعديل فى الاصدار الثانى واحب هنا ان اشكر مشرفين الموقع والاستاذ محمد طاهر للتشجيع المستمر وانا لم اتعلم شيئ الا من هذا الموقع الرائع وهذا رابط اخر علــى الميديا فاير اطلس العالم 1

السلام عليكم و رحمة الله تعالى و بركاته: أستاذ محمد حياك الله و بعد إذنك. هناك فكرة ممتازة قدمها لنا الأستاذ جعفر توضع في الجدول و قد قمت بإضافتها إلى النموذج و تم حل المشكلة بنجاح بإذن الله تعالى. 1- إذهب إلى خصائص مربع النص حاسب في خاصية تنسيق و أجري التعديلات التالية كما في الصورة: و سوف تصبح كالتالي: 2- قم بنفس التعديلات على الحقل حاسب في جدول test على خاصية تنسيق كالتالي: 3- ثم إذهب إلى الكود خلف زر ترقيم و عدل عليه كالآتي: Me.حاسب = AutoNumber("Test", "حاسب") و هذا هو التعديل على المرفق: AutoNumber.rar

السلام عليكم ورحمة الله أخي الكريم، تم التعديل على عناوين الجداول لمطابقتها مع أسماء الشيتات وإدخال دالة INDIRECT على المعادلات حسب هذه التعديلات... إن شاء الله يكون في الملف المرفق ما يفي المطلوب ..... أخوك بن علية Indirect_ifs.rar