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

لا ضرورة لرفع ملف فيه الوف الصفوف و تنسيقات مزركشة مما يزيد حجم الملف الى أكثر من واحد ميغا لأن الماكرو الذي يعمل على صف واحد يمكنه العمل على الألوف من الصفوف جرب ان تفعل في الورفة كما في الصورة المرفقة 1- تغيير اسمها الى اي شيئ شرط باللغة الاجنبية (لحسن نسخ الماكرو ولصقه) انا اسميتها Salim 2- اضافة صفين فارغين نماماً (اركز على كلمة فارغين تماماً) الصف رقم 2 والصف رقم 4 (هذه الصفوف مخفية للمنظر من حهة ولعدم كتابة اي شيء فيها عن طريق الحطأ من جهة اخرى) بحيث تيدأ البيانات من الصف الخامس الصف رقم3 عناوبن (وذلك لفصل البياتات المتغيرة غن الثابتة) 3- نفذ هذا الماكرو Sub Serial_number() Dim Rg_A As Range Dim Lra#, k%, i% k = 1 With Sheets("Salim") Set Rg_A = .Range("A5").CurrentRegion.Columns(1) Rg_A.ClearContents Lra = Rg_A.Rows.Count - 1 For i = 5 To Lra .Cells(i, 1) = k k = k + 1 i = i - 1 + .Cells(i, 1).MergeArea.Rows.Count Next End With End Sub mh_syr.xlsm

وعليكم السلام- وبما انك لم ترفع ملف فإليك الكود أيضاً بدون ملف Private Sub CommandButton1_Click() Calculate End Sub

للأسف اخي الكريم لا يعمل غندي البرنامج نسخة 2019

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

اين ذهبت الأرقام؟؟؟؟ اليك الملف كاملاً مع زر الطباعة Ritage_With_Print.xlsm

لا أعلم السبب عندك سبب طهور الرسالة هو ان هذه الرحلة موجودة فعلاً لذلك يجب 1- حذفها أولاً من الشيت داتا الزر رفم 2 لان الماكرو لا يضيفها اذا كانت موجودة في هذا الشيت( لا يسمح بالتكرار) 2- اجراء التعديلات اللازمة 3-ارسالها الى الشيت داتا من جديد الزر رفم 5 4-التأكد من ان كل شيء في مكانه الصحيح بواسطة الزر 6 استدعاء عندي بعمل بشكل طبيعي تأكد من اجراء الخطوات بشكل صحيح بالنسبة للطباعة هذا الكود Sub Print_Me() Dim My_last%, Inv As Worksheet Set Inv = Sheets("Invoice") My_last = Application.Max(Inv.Range("B13:B32")) + 12 Inv.PageSetup.PrintArea = Inv.Range("B1:G" & My_last).Address Inv.PrintPreview End Sub مع امكانية استبدال السطر (الذي يظهر منظر الصفحة قبل طباعتها) Inv.PrintPreview بهذا السطر (الذي يرسل الصفحة مباشرة الى الطباعة) Inv.PrintOut

لاجراء اي تعديل اتبع الحطوات حسب الصورة 1- حدد رقم الرحلة (المربع الأزرق) 2- اضغط الزر رقم 2 (يتم مسح البيانات الخاصة بالرحلة /التابعة للمربع الأزرق/ من الشيت داتا) 3- اضغط الزر رقم 3 (يتم جلب البيانات من الشيت الأساسية "الرحلات_المعتمرين" الى العامودين (اللون الأخضر) 4- قم بتعديل ما تريد في عامود (نوع الغرفة) 5- اضغط الزر رقم 5 (تذهب البيانات الجديدة الى الشيت داتا) أحر صف كان غير فارغ 6-اضغط الزر رقم 6 (لنقل الاسماء بعد التعديل الى الجدول) مرفق الملف معدلاً Ritage_Final_File.xlsm

اتمني ان يفيدك https://www.dafont.com/theme.php?cat=711 ده خطوط باركود

جزاك الله خيرا وجعله الله في موازين حسناتكم

وعليكم السلام ورحمة الله وبركاته اتفضل اليك هذا Option Compare Database Function RiaziyatTxtToNum(SText) ' By Shivan Rekany Dim i, ii As Integer Dim Elamat Dim Encam As Double Dim sERCEM As Double Dim JimaaZuF As Integer For ii = 1 To Len(SText) If Mid(SText, ii, 1) = "+" Or Mid(SText, ii, 1) = "*" Or Mid(SText, ii, 1) = "/" Or Mid(SText, ii, 1) = "-" Then JimaaZuF = JimaaZuF + 1 End If Next ii Dim LString As String Dim LArray() As String LString = Replace(Replace(Replace(SText, "+", "*"), "-", "*"), "/", "*") LArray = Split(LString, "*", Val(JimaaZuF + 1)) For ii = 1 To Len(SText) If Mid(SText, ii, 1) = "+" Or Mid(SText, ii, 1) = "*" Or Mid(SText, ii, 1) = "/" Or Mid(SText, ii, 1) = "-" Then Elamat = Elamat & Mid(SText, ii, 1) Next ii Encam = Val(LArray(0)) For i = 1 To Len(Elamat) If Mid(Elamat, i, 1) = "+" Then Encam = Encam + Val(LArray(i)) ElseIf Mid(Elamat, i, 1) = "*" Then Encam = Encam * Val(LArray(i)) ElseIf Mid(Elamat, i, 1) = "/" Then Encam = Encam / Val(LArray(i)) ElseIf Mid(Elamat, i, 1) = "-" Then Encam = Encam - Val(LArray(i)) End If Next i RiaziyatTxtToNum = Trim(Encam) Form_TBL1.sERCEM = RiaziyatTxtToNum End Function واليك ملف تم تطبيق عليه Database2.accdb

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

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

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

جزاك الله خيرا

وعليكم السلايمكنك استخدام هذا الكود لذلك Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) If (Not Application.Intersect(Target, Me.Range("d9:M18,D19:E19")) Is Nothing) Then Cancel = True Target.Interior.ColorIndex = 15 End If End Sub Cells Colored.xlsm

لعكس الترتيب استبدل قي هذا السطر من الكود الرقم 2 بالرقم 1 Dash.Range("A3").CurrentRegion.Sort Dash.Range("E3"), 2, Header:=1 تم التعديل على الملف كما تريد ( و زيادة حبتين من حيث التنسيق) Option Explicit Sub From_dash_to_data() Dim Dash As Worksheet, Dt As Worksheet Dim Cret As Range, x%, y%, Ro_D Application.ScreenUpdating = False Set Dash = Sheets("Dashboard"): Set Dt = Sheets("DATA") Dash.Range("A3").CurrentRegion.Clear Ro_D = Dt.Range("A3").CurrentRegion.CurrentRegion.Rows.Count If Dash.Range("C1") = "" Then MsgBox "Pleae Type A number In The cell C1" & Chr(10) & _ "Last Than " & Ro_D - 2 GoTo Bay_Bay End If If Not IsNumeric(Dash.Range("C1")) Then MsgBox "Tex Not Allowed in The cell C1" & Chr(10) & _ "Pleae Type A number" GoTo Bay_Bay End If y = Int(Abs(Dash.Range("C1"))) Dash.Range("C1") = y Set Cret = Dash.Range("A1") Dt.Range("A1").CurrentRegion.AutoFilter 1, Cret Dt.Range("A1").CurrentRegion.SpecialCells(12).Copy Dash.Range("A3").PasteSpecial (12) Dash.Range("A3").CurrentRegion.Sort Dash.Range("E3"), 2, Header:=1 x = Dash.Range("A3").CurrentRegion.CurrentRegion.Rows.Count If x - y < 2 Then With Dash.Range("A4").Offset(x - 1, 2) .Value = Evaluate("=SUM(C4:C" & x + 2 & ")") .Interior.ColorIndex = 3 .Font.ColorIndex = 2 End With Else Dash.Range("A4").Offset(y) _ .Resize(x - y - 1).EntireRow.Delete With Dash.Range("A3").Offset(y + 1, 2) .Value = Evaluate("=SUM(C4:C" & y + 3 & ")") .Interior.ColorIndex = 3 .Font.ColorIndex = 2 End With End If Application.CutCopyMode = False If Dt.AutoFilterMode Then Dt.Range("A1").AutoFilter Dash.Activate With Dash.Range("A3").CurrentRegion .Borders.LineStyle = 1 .InsertIndent 1 .Font.Bold = True .Font.Size = 14 .Rows(1).Interior.ColorIndex = 35 .Rows(1).HorizontalAlignment = 3 End With Dash.Range("A3").Select Bay_Bay: Application.ScreenUpdating = True End Sub الملف من جديد Hashem_Super.xlsm

جرب هذا الماكرو Option Explicit Sub test() Dim Ro%, Rg As Range Dim x%, t%, i% With Sheets("ورقة1") Ro = .Cells(Rows.Count, 1).End(3).Row Set Rg = .Range("A1:A" & Ro).SpecialCells(2, 23) .Range("E1").Resize(Ro, 2).Clear t = 1 For x = 1 To Rg.Areas.Count .Cells(t, "E").Resize(Rg.Areas(x).Rows.Count) = _ Rg.Areas(x).Cells(1, 1) .Cells(t, "E").Interior.ColorIndex = 6 For i = 2 To Rg.Areas(x).Rows.Count .Cells(t + 1, "F").Offset(i - 2) = _ Rg.Areas(x).Cells(i).Offset(, 2) Next i t = t + Rg.Areas(x).Rows.Count + 1 Next x With .Range("E1").Resize(Ro, 2).SpecialCells(2, 23) .Borders.LineStyle = 1 .Font.Bold = True .InsertIndent 1 End With End With End Sub الملف مرفق Sakr_Khalige.xls

بارك الله فيك استاذ صالح وجعل هذا العمل فى ميزان حسناتك - ورحم الله والديك , اللهم اجعلهم فى اعلى الدرجات وأدخلهم فسيح جناتك ... جنات الفردوس الأعلى واغفر لهم وارحمهم اللهم وسع فى رزقك استاذ صالح واصلح لك اولادك واجعلهم يارب ممن يستمعون القول فيتبعون احسنه وبارك اللهم لك فيهم

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

استاذ احمد لكم منا كل الحب والاحترام وشكرا على تفاعلكم معى فى الموضوع

اتفضل حسب فهمي لطلبك استخدمت هذه الاكواد Public Sub a_AfterUpdate() If Len(Me.a & "") <> 0 And Len(Me.b & "") = 0 And Len(Me.C & "") = 0 Then Me.Filter = "[Safe]='" & Me.a & "'" Me.FilterOn = True ElseIf Len(Me.a & "") <> 0 And Len(Me.b & "") <> 0 And Len(Me.C & "") = 0 Then Me.Filter = "[Safe]='" & Me.a & "'" & "and [Sub]='" & Me.b & "'" Me.FilterOn = True ElseIf Len(Me.a & "") <> 0 And Len(Me.b & "") <> 0 And Len(Me.C & "") <> 0 Then Me.Filter = "[Safe]='" & Me.a & "'" & "and [Sub]='" & Me.b & "'" & "and [Class]='" & Me.C & "'" Me.FilterOn = True ElseIf Len(Me.a & "") = 0 And Len(Me.b & "") <> 0 And Len(Me.C & "") <> 0 Then Me.Filter = "[Sub]='" & Me.b & "'" & "and [Class]='" & Me.C & "'" Me.FilterOn = True ElseIf Len(Me.a & "") = 0 And Len(Me.b & "") = 0 And Len(Me.C & "") <> 0 Then Me.Filter = "[Class]='" & Me.C & "'" Me.FilterOn = True ElseIf Len(Me.a & "") <> 0 And Len(Me.b & "") = 0 And Len(Me.C & "") <> 0 Then Me.Filter = "[Safe]='" & Me.a & "'" & "and [Class]='" & Me.C & "'" Me.FilterOn = True ElseIf Len(Me.a & "") = 0 And Len(Me.b & "") <> 0 And Len(Me.C & "") = 0 Then Me.Filter = "[Sub]='" & Me.b & "'" Me.FilterOn = True ElseIf Len(Me.a & "") = 0 And Len(Me.b & "") = 0 And Len(Me.C & "") = 0 Then Me.Filter = "" Me.FilterOn = False End If End Sub Private Sub b_AfterUpdate() Call a_AfterUpdate End Sub Private Sub BtnCancelFilter_Click() Me.a = "": Me.b = "": Me.C = "": Me.Filter = "": Me.FilterOn = False End Sub Private Sub C_AfterUpdate() Call a_AfterUpdate End Sub اليك ملفك بعد اضافة Database1.rar

لتبسيط العمل ارى انه من الافضل كتابة نوع الغرفة امام كل اسم ( في العامود "L" لفصله عن بقية البيانات بعامود فارغ " K " ) في الصورة العامود " K " فارغ (محفي ) 2=ثنائية / 3=ثلاثية وهكذا اختصاراً للوقت ثم الضغط على الزر الأخضر لاستدعاء البيانات اضغط الزر استدعاء الصورة توضح ذلك Ritage_Super_with_dict.xlsm

Kabo223412 أين انت من هذه الإجابة الممتازة؟!!! أين الضغط على الإعــــجـــــاب , وكما اتفقنا ان هذا أقل ما يقدم لمن له الفضل عليك بعد ربنا فى حل مشكلتك وتفريج كربتك ؟!!!💙

جرب المرفق شهر10.xlsm

اتفضل اليك ما طلبت القي نظرتا الى الصورة واليك المرفق بعد تعديل تقسيم الاسم الرباعي.mdb شفان

أخي الحبيب ياسر (أبو البراء) تفضل، هذا طلبك.. وآني الممنون. جدول الضرب2 .. الحل.rar جدول الضرب..فيديو.rar

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

بالفعل وهذا تعديل للمعادلة =IF(AND(ROWS($A$1:$A1)<=$J$2;COLUMNS($A$1:A$1)<=$K$2);ROWS(A$4:A4)+(COLUMNS($A4:A4)-1)*$J$2;"")

وعليكم السلام محاولة للإجابة على لغز جدول متحرك ضع هذه المعادلة في الخلية B4 ثتم إسحب الى الأسفل والى اليسار =IF(OR(ROW()-3>$J$2;COLUMN()-1>$K$2);"";((COLUMN()-2)*$J$2)+ROW()-3) تحياتي

بجد الموضوع ده رائع ... لانه بيخلى الواحد يدور على طرق جديدة وسهلة ومختصرة غير اللى يعرفها لحل المشكلة ... تحياتي أ.ياسر انا قبل البحث كنت اعرف طريقتين ... الأولى الطريقة التقليدية بدون معادلات او اكواد ( بتحديد النطاق ثم بحث Find ثم Go to Special واختار Blanks >>> وبعدها اكتب الاسم اللى عايزه وليكن "Ibn_Egypt" واضغط Ctrl+Enter الثانية الكود العادي اللى بنستخدمه دائما في البرامج بعمل حلقة تكرارية تقوم بتعبئة الفراغات كده Sub Fill_Blanks() Application.ScreenUpdating = False For Each cell In Range("A1:B10") ' Or we can type If Len(cell) = 0 Then If IsEmpty(cell) Then cell.Value = "Ibn_Egypt" End If Next Application.ScreenUpdating = True End Sub لكن لعلمى انك طرحت سؤال زي ده فأكيد فيه حاجة اسهل من الطريقتين دول ... وبعد البحث لقيت السطر ده بس وبيقوم بالغرض تمام Sub Fill_Blanks2() Range("A1:B10").SpecialCells(xlCellTypeBlanks).Value = "Ibn_Egypt" End Sub تحياتي وتقديري استاذي الفاضل وجعل اللهم عملك في ميزان حسناتك وإلي اللقاء في لغز آخر

أخى الكريم اذا أردت البحث عن مشاركات أى عضو هنا فى المنتدى 1- اذهب إلى الصفحة الشخصية الخاصة به عن طريق الضغط على اسم العضو (وذلك فى أى مشاركة له) 2- اضغط على زر Find Content 3- ستظهر كل المواضيع التى شارك بها هذا العضو 4- وعلى الجزء الأيمن من النافذة تجدالآتى: See this member's: 1-Topics and posts 2-Only topics 3-Only posts حيث : رقم واحد لاظهار كل المواضيع والمشاركات الخاصه بالعضو رقم اثنان لاظهار المواضيع التى أنشاها العضو فقط رقم ثلاثة لاظهار المشاركات التى قام بها العضو فقط اضغط على أى خيار لفلترة المشاركات الخاصة بالعضو فى المنتدى أرجو أن يكون هذا طلبك أخى وهذا رابط لكل المواضيع التى أنشاها الأستاذ خبور فقط وهى 137 موضوع: [searchInKey]=&userMode=title]http://www.officena.net/ib/index.php?app=core&module=search&do=user_activity&search_app=forums&mid=11314&sid=a057776dec033cc084b62332d92f9f3d&search_app_filters[forums][searchInKey]=&userMode=title

تفضلى http://www.officena....oor/topics1.htm احترامى

بسم الله الرحمن الرحيم وبه نستعين الاخت الفاضلة الاستاذة / صفاء السلام عليكم ورحمته الله وبركاته ليس من الصعب على القائمين على المنتدى تجميع أعمال الاستاذ الفاضل / خبورخير ولكن الموضوع فى اعتقادى يحتاج لوقت كبير لانجاز هذه المهمه ولحصر جميع مشاركته فقط عليكى الدخول على الملف الشخصى للعلامة خبور خير بالضغط على " مشاركاتى " ستجدى جميع المشاركات الخاصة به من أول مشاركة حتى أخر مشاركة واحتفظى بالرابط على Favorites واليكى هذة الروابط http://www.officena....oor/topics1.htm http://khboor.posterous.com/87143053 وفقنا الله تعالى واياكم ... وجزاكم الله خيرا

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

السلام عليكم أخي عامر المعادلة بسيطة و تأخذ النسق العادي للمعادلة التي تعودنا عليها MTACH and INDEX و لكن الفرق الوحيد هو في المرجع [color="#666600"]=[/color]INDEX[color="#666600"]([/color]INDIRECT[color="#666600"]([/color][color="#008800"]"'"[/color][color="#666600"]&[/color]$B$1[color="#666600"]&[/color][color="#008800"]"'!"[/color][color="#666600"]&[/color][color="#008800"]"b3:b14"[/color][color="#666600"]),[/color]MATCH[color="#666600"]([/color]$B4[color="#666600"],[/color]INDIRECT[color="#666600"]([/color][color="#008800"]"'"[/color][color="#666600"]&[/color]$B$1[color="#666600"]&[/color][color="#008800"]"'!"[/color][color="#666600"]&[/color][color="#008800"]"c3:c14"[/color][color="#666600"]),[/color][color="#006666"]0[/color][color="#666600"]))[/color] و لأن المرجع متغير و مرتبط بأكثر من صفحة و إسم المرجع يعتمد على اسم الصفحة الموجود في الخلية B1 و إضافة لذلك نريد مدى محدد و هذا المدى هو نفسه في جميع الصفحات حيث أننا نريد المدى الأول b3:b14 لإستخراج أسماء الأشهر و المدى الثاني c3:c14 لتحديد موقع القيمة و حسب المعطيات أعلاه فإن أفضل طريقة هي إستخدام الدالة INDIRECT و بالعودة إلى إحدى أساسيات الأكسيل و هي عند الإشارة إلى خلية في صفحة يتكون اسمها من مقطع واحد مثلا Yahya =Yahya!A2 فقط نضع علامة ! بين اسم الصفحة و عنوان الخلية إما إذا كان سم الصفحة مكون من مقطعين مثلا Yahya Hussien ='Yahya Hussien'!A1 نضيف فاصله علوية واحد قبل الإسم و بعده و هذا ما فعلناه مع الدالة INDIRECT INDIRECT[color="#666600"]([/color][color="#008800"]"'"[/color][color="#666600"]&[/color]$B$1[color="#666600"]&[/color][color="#008800"]"'!"[/color][color="#666600"]&[/color][color="#008800"]"b3:b14"[/color][color="#666600"])[/color] الخلية b1 بها اسم Yahya و المدى b3:b14 يحتنوي أسماء الأشهر و عند عمل Evaluate للمعادلة ستعيد المدى التالي ={"Jan";"Feb";"Mar";"Apr";"May";"Jun";"Jul";"Aug";"Sep";"Oct";"Nov";"Dec"} و نفس الشيء بالنسبة للمدى الأخر و هذا يسهل عمل الدالة INDEX and MATCH ================ و دمتم في حفظ الله و رعايته اعذرني على عدم استخدام الشرح بالصور