Yasser Fathi Albanna

السلام عليكم ورحمة الله وبركاته كل عام وحضراتكم جميعا بخير أعاده الله عليكم بالخير واليمن والبركات إستفسار بسيط محيرني جدا عبارة عن عندي رقم 177.63 عايز أعرف أصل الرقم ده قبل ما يتخصم منه ١٦% حسبتها أقسمت ١٧٧.٦٣ في ١.١٦ طلع الرقم ( ٢٠٦.٠٥٠٨ ) عايز أحسب ( ٢٠٦.٠٥٠٨ ) بالمعادلة الأتية تطلع نفس القيمة ( ١٧٧.٦٣ ) والمعادلة هي =206.0508-(206.0508*16% ) تعطي نفس القيمة 177.63 بيطلع الناتج مختلف ممكن أعرف السبب الناتج طلع ( ١٧٣.٠٨٢ ) يرجي الإفادة مع خالص الشكر .... عنوان مخالف , تـــم تعديل عنوان المشاركة ليعبر عن طلبك

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

تفضل أخى نسخة شاملة ال 64 و 32 فرنسية https://officecdn.microsoft.com/pr/492350f6-3a01-4f97-b9c0-c7c6ddf67d60/media/fr-fr/ProPlus2019Retail.img

بارك الله فيك أخى الفاضل

أ/ أحمد يوسف & أ / أحمد الطحان يرجى تجربة هذا الرابط عن تجربه https://officecdn.microsoft.com/pr/492350f6-3a01-4f97-b9c0-c7c6ddf67d60/media/ar-sa/ProPlus2019Retail.img النسخة عربى

أخي الفاضل أ / احمد يوسف قم بفك الضغط عن الملف عن طريق برنامج Winrar

أ/ أحمد يوسف شكرا لزوق حضرتك جرب هذا الرابط https://ia802905.us.archive.org/24/items/MOfProPl201916.0.10325.20118FullX86/M_Of_Pro_Pl_2019_16.0.10325.20118_full_x86.zip

تم تعديل الرابط أخى الفاضل

تفضل أخى الفاضل أ / أحمد الطحان Microsoft Office Professional Plus 2019 Arabic 32bit http://f3.file-upload.com:182/d/rexnb3fhnlgpv7w7t22ikdqpy3k5axwapfqfjzyxpo6bdrejtahyuvox7xfdwm3mvf5cfhz6/ProPlus2019Retail_AR_sigma4pc.com.rar التفعيل C2R-R2V_5.7z

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

السلام عليكم ورحمة الله وبركاته السادة الأفاضل الأساتذه الأفاضل أحباء هذا الصرح العظيم أقدم لكم اليوم Microsoft Office Professional Plus 2019 أرجوا أن ينال إجابكم https://officecdn.microsoft.com/pr/492350f6-3a01-4f97-b9c0-c7c6ddf67d60/media/en-us/ProPlus2019Retail.img

السلام عليكم ورحمة الله وبركاته تحية طيبة وبعد إخوانى وأخواتى وأساتذتى أعضاء المنتدى العظيم الذى تعلمت منه الكثير والكثير أقم لكم اليوم كود برمجى وهو عبارة عن كود يوضع داخل موديول لفك حماية بيانات محددة محمية داخل شيت إكسيل أرجوا أن ينال إعجابكم وشكرا Sub PasswordBreaker() Dim i As Integer, j As Integer, k As Integer Dim l As Integer, m As Integer, n As Integer Dim i1 As Integer, i2 As Integer, i3 As Integer Dim i4 As Integer, i5 As Integer, i6 As Integer On Error Resume Next For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If ActiveSheet.ProtectContents = False Then MsgBox "One usable password is " & Chr(i) & Chr(j) & _ Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) ActiveWorkbook.Sheets(1).Select Range("a1").FormulaR1C1 = Chr(i) & Chr(j) & _ Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Exit Sub End If Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next End Sub

السلام عليكم ورحمة الله وبركاته تحية طيبة وبعد إخوانى وأخواتى وأساتذتى أعضاء المنتدى العظيم الذى تعلمت منه الكثير والكثير أقم لكم اليوم كود برمجى وهو عبارة عن كود يوضع داخل موديول لفك حماية بيانات محددة محمية داخل شيت إكسيل أرجوا أن ينال إعجابكم وشكرا Sub PasswordBreaker() Dim i As Integer, j As Integer, k As Integer Dim l As Integer, m As Integer, n As Integer Dim i1 As Integer, i2 As Integer, i3 As Integer Dim i4 As Integer, i5 As Integer, i6 As Integer On Error Resume Next For i = 65 To 66: For j = 65 To 66: For k = 65 To 66 For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66 For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66 For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126 ActiveSheet.Unprotect Chr(i) & Chr(j) & Chr(k) & _ Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _ Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) If ActiveSheet.ProtectContents = False Then MsgBox "One usable password is " & Chr(i) & Chr(j) & _ Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) ActiveWorkbook.Sheets(1).Select Range("a1").FormulaR1C1 = Chr(i) & Chr(j) & _ Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _ Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n) Exit Sub End If Next: Next: Next: Next: Next: Next Next: Next: Next: Next: Next: Next End Sub

للرفع ولكم خالص الشكر

للرفع ولكم خالص الشكر والتقدير

سلمت يمينك وحفظك الله وزادك من علمه الكثير والكثير الأخ والأستاذ القدير / بن علية حاجي معادلة أكثر من رائعة تقبل تحياتى

بعد إزن أخي الحبيب / بن علية حاجي ممكن تطبيق بالفكرة

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

السلام عليكم ورحمة الله وبركاته السادة الأفاضل يظهر لى رسائل عند فتح شيت إكسيل وعند الخروج منها وفتح الشيت أريد الحفظ لا يتم الحفظ ويريد الحفظ بإسم أخر

السلام عليكم ورحمة الله وبركاته مرفق الملف موضح به المطلوب Rank.rar

الحمد لله رب العالمين تم ضبط الكود بعد معاناه ولكن قام بالغرض المطلوب فهل من إمكانية لتسريع الكود وهو للأستاذ القدير الغالى الذى أكن له كل إحترام وتقدير / العيدروس والكود هو Private Function Ali(Ln As Long, Vl, Bl As String, Bln As Boolean) Dim Shet As Worksheet Dim Do_Ali Dim Ar() As Variant Dim iCnt& Dim X, A Dim XX As Integer On Error Resume Next Set Shet = Sheets("Report") Set Do_Ali = CreateObject("Scripting.Dictionary") With Application .ScreenUpdating = False .EnableEvents = True DoEvents With Shet Lr = .Cells(.Rows.Count, 2).End(xlUp).Row Ar = .Range("A2:F" & Lr).Value: A = Bl For R = LBound(Ar, 1) To UBound(Ar, 1) If Ar(R, 3) = A Then If Not Bln Then If Vl = 3 Then ZZ = Ar(R, 2): ZZZ = Ar(R - 1, 2) If ZZZ <> ZZ Then X = X + 1 End If End If If Vl = 4 Or Vl = 2 Then X = X + Ar(R, 6): XX = XX + 1 End If End If If Do_Ali.exists(Ar(R, Ln)) Then Do_Ali.Item(Ar(R, Ln)) = Do_Ali.Item(Ar(R, Ln)) + 1 Else Do_Ali.Add Ar(R, Ln), 1 End If End If Next Ali = IIf(Vl = 1, Do_Ali.Count, IIf(Vl = 2, XX, X)) End With .ScreenUpdating = True .EnableEvents = False End With Erase Ar Set Do_Ali = Nothing Set Shet = Nothing End Function Sub Ali_Count() Dim Sh As Worksheet Dim Sht As Worksheet Dim R, Rr, Cll, Lrr Set Sh = Sheets("Rank") Set Sht = Sheets("Report") With Sh Lrr = Sht.Cells(Rows.Count, 2).End(xlUp).Row Sht.Sort.SortFields.Add Key:=Sht.Range("A2:A" & Lrr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With Sht.Sort .SetRange Sht.Range("A1:F" & Lrr) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Rr = 10: Cll = 24 For R = Rr To Cll If .Cells(R, 2) <> "" Then .Cells(R, 4) = Ali(1, 4, .Cells(R, 2), False) .Cells(R, 9) = Ali(1, 3, .Cells(R, 2), False) .Cells(R, 14) = Ali(4, 1, .Cells(R, 2), False) .Cells(R, 19) = Ali(1, 1, .Cells(R, 2), True) End If Next End With MsgBox "Greetings with Engineer / Yasser Fathi Al-Banna " End Sub Rank.rar

الأستاذ والمعلم القدير ياسر خليل بعد التحية لقد تم إجابة حضرتك على هذا العمل من قبل بهذ الكود الرائع والسريع أيضا ولكن أريد به تعديل بسيط جدا الخانة التى إسمها P C أريد أن تعد فقط العميل مرة واحدة فقط حتى لو أخذ أكثر من فاتورة بتاريخ اليوم ويعد نفس العميل حتى لو أخذ فاتورة يوميا بس بتاريخ مختلف يعنى العميل يعد مرة واحدة فقط مرتبط بالتاريخ والكود كالتالى Sub Test() Dim Coll As New Collection, CollDummy1 As New Collection, CollDummy2 As New Collection Dim ArrData, ArrIn, ArrOut1(), ArrOut2(), ArrOut3(), ArrOut4(), ArrCalc(), ArrTemp Dim I As Long, P As Long With Sheets("Report") ArrData = .Range("A2:F" & Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row, 2)) End With With Sheets("Rank") ArrIn = .Range("B10:B" & Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row, 10)) End With ReDim ArrOut1(1 To UBound(ArrIn, 1), 1 To 1) ReDim ArrOut2(1 To UBound(ArrIn, 1), 1 To 1) ReDim ArrOut3(1 To UBound(ArrIn, 1), 1 To 1) ReDim ArrOut4(1 To UBound(ArrIn, 1), 1 To 1) ReDim ArrCalc(1 To UBound(ArrData, 1), 1 To 2) On Error Resume Next For I = 1 To UBound(ArrData, 1) Set CollDummy1 = Nothing Set CollDummy2 = Nothing Coll.Add Key:=ArrData(I, 3), Item:=Array(Coll.Count + 1, CollDummy1, CollDummy2) ArrTemp = Coll(ArrData(I, 3)) ArrTemp(1).Add Key:=ArrData(I, 4), Item:=Empty ArrTemp(2).Add Key:=ArrData(I, 1), Item:=Empty P = ArrTemp(0) ArrCalc(P, 1) = ArrCalc(P, 1) + ArrData(I, 6) ArrCalc(P, 2) = ArrCalc(P, 2) + 1 Next I On Error GoTo 0 For I = 1 To UBound(ArrIn, 1) On Error Resume Next ArrTemp = Coll(ArrIn(I, 1)) If Err.Number = 0 Then ArrOut1(I, 1) = ArrCalc(ArrTemp(0), 1) ArrOut2(I, 1) = ArrCalc(ArrTemp(0), 2) ArrOut3(I, 1) = ArrTemp(1).Count ArrOut4(I, 1) = ArrTemp(2).Count End If On Error GoTo 0 Next I Application.ScreenUpdating = False With Sheets("Rank") .Range("D10").Resize(UBound(ArrOut1, 1), 1).Value = ArrOut1 .Range("I10").Resize(UBound(ArrOut2, 1), 1).Value = ArrOut2 .Range("N10").Resize(UBound(ArrOut3, 1), 1).Value = ArrOut3 .Range("S10").Resize(UBound(ArrOut4, 1), 1).Value = ArrOut4 End With Application.ScreenUpdating = True End Sub ولسيادتكم خالص الشكر والتقدير

سلمت يمينك الأستاذ والمعلم القدير / بن علية حاجي كود رائع شكرا جزيلا

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

السلام عليكم ورحمة الله وبركاته تحية طيبة وبعد أريد كود برمجى يقوم بمسح الخلايا المظللة باللون الأصفر فقط ولسيادتكم خالص الشكر والتقدير Delete.rar