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

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

السلام عليكم تم عمل المطلوب في كل من ملفي وملف أخي الكريم سليم... بن علية حاجي My_count_Salim.xlsm My_count_hben.xlsm

ربما كان هذا الكود اسرع بحوالي 10 مرات باستعمال الدالتين Find & FindNext Sub search_by_salim_Method() Dim My_rg As Range Dim Find_rg As Range Dim find_What$ Dim Ro#, FiXed_Ro# Dim k#: k = 3 With Sheets("ورقة1") Set My_rg = .Range("A4").CurrentRegion.Columns(1) find_What = .Range("E1").Value .Range("E3:G1000").ClearContents End With Set Find_rg = My_rg.Find(find_What, lookat:=1) If Not Find_rg Is Nothing Then Ro = Find_rg.Row FiXed_Ro = Ro Do With Sheets("ورقة1").Range("E" & k).Resize(, 3) .Value = Sheets("ورقة1").Range("A" & Ro).Resize(, 3).Value End With k = k + 1 Set Find_rg = My_rg.FindNext(Find_rg) Ro = Find_rg.Row If Ro = FiXed_Ro Then Exit Do Loop Else MsgBox "This Item Not Exists" End If Set My_rg = Nothing: Set Find_rg = Nothing End Sub الملف مرفق الرجاء النظر الى هذه الملف لمعرفة ما أعنية من وجهة نظر السرعة Search_by_find_timer .xlsm

تفضل يمكنك استخدام هذه المعادلة =SUMIFS(سعر!$A:$A,سعر!$C:$C,A2,سعر!$D:$D,B2) test.xlsx

ربما كان هذا الكود اسرع بحوالي 100 مرة باستعمال الدالتين Find & FindNext Sub search_by_salim_Method() Dim My_rg As Range Dim Find_rg As Range Dim find_What$ Dim Ro#, FiXed_Ro# Dim k#: k = 3 With Sheets("ورقة1") Set My_rg = .Range("A4").CurrentRegion.Columns(1) find_What = .Range("E1").Value .Range("E3:G1000").ClearContents End With Set Find_rg = My_rg.Find(find_What, lookat:=1) If Not Find_rg Is Nothing Then Ro = Find_rg.Row FiXed_Ro = Ro Do With Sheets("ورقة1").Range("E" & k).Resize(, 3) .Value = Sheets("ورقة1").Range("A" & Ro).Resize(, 3).Value End With k = k + 1 Set Find_rg = My_rg.FindNext(Find_rg) Ro = Find_rg.Row If Ro = FiXed_Ro Then Exit Do Loop Else MsgBox "This Item Not Exists" End If Set My_rg = Nothing: Set Find_rg = Nothing End Sub الملف مرفق Search_by_find.xlsm

تفضل اخى الكريم بعد اذن الأستاذ وجيه يمكنك استخدام هذه المعادلة لأعلى مرتب =SUMPRODUCT(MAX((ورقة1!$B$2:$B$13=$B2)*(ورقة1!$D$2:$D$13))) وبالنسبة لأقل مرتب يمكنك استخدام هذه المعادلة =DMIN(ورقة1!$B$1:$D$13,3,$B$1:B2)

وعليكم السلام -كود ممتاز استاذ ابراهيم احسنت كل عام وانتم بخير تقبل الله منكم سائر الأعمال

السلام عليكم جرب ما وضعته في الملف المرفق... بن علية حاجي نموذج ارتباطات المستلزمات المكتبية.xlsx

السلام عليكم ورحمة الله تم عمل المطلوب بواسطة كود VBA ومعادلات... بن علية حاجي My_count.xlsm

أخي @حلبي اخيرا وجدت الملف .. الملف من تطوير أعتقد أخونا الغالي @محمد سلامة أسائل الله أن يجزيه عنا وعن المسلمين خيراً طبعاً الملف الذي أضاف الأستعادة تطوير أحد أخوة من زملائنا بالمنتدى الغالي أوفيسنا .. لا أتذكر من الأخ.... الذي أخذت منه الملف .. أو أنه يطلع أخونا @مسفر وأنا لا أدري وياريت أعرف أسمه أضعة بجانب الملف حتى أتذكره وأدعو له المهم ... هو كذلك أسائل الله أن يجزيه عنا وعن المسلمين خيراً .. مرفق الملف Backup.rar

بعد اذن استاذنا واخونا الحبيب الاستاذ على جلب قيمة بناء على التاريخ نسخة من test.xlsx

السلام عليكم رمضان تسلم استاذ علي

أين الملف لابد من رفع الملف نفسه مع شرح كافى على الملف لما هو مطلوب كيف يمكن العمل على الصورة ؟ّ!!!

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

استاذى الفاضل واخى الحبيب الاستاذ سليم كل عام وحضراتكم بخير بخلول شهر رمضان المبارك اعاده الله عليكم وعلى الامة الاسلامية بالخير واليمن والبركات وبعد اذن الاستاذ ابراهيم الحداد اتفضل الملف لعله يفى بالغرض وادعو الله ان اكون عند حسن ظن استاذى الجليل والحبيب الاستاذ سليم sa.xlsm

بارك الله فيكم استاذ على وجزاكم الله خير

مشاء الله عليك استاذ ابراهيم الحداد .. الله الله.. زادك الله علما وحفطك من كل سوء.

رمضان كريم و مبارك على الحميع بعد اذن اخي بن علية في حال استعمال الكود يمكن عمل ذلك بدون أعمدة مساعدة ( أقصد العامود T ) و حتى بدون معادلات Countif الكود Option Explicit Sub Salim_Unique_Data_And_count() Dim Rng As Range [b9:i10].ClearContents Dim dt As Object Set dt = CreateObject("Scripting.Dictionary") For Each Rng In [B2:I6] If Rng.Value <> vbNullString Then dt(Rng.Value) = _ IIf(Not dt.exists(Rng.Value), 1, dt(Rng.Value) + 1) End If Next Range("b9").Resize(1, dt.Count) = dt.Keys Range("b10").Resize(1, dt.Count) = dt.Items dt.RemoveAll: Set dt = Nothing End Sub الملف مرفق My_count_Salim.xlsm

أخي العزيز اعتقد انك لم تقرأ الوحدة النمطية بشكل جيد Public Sub TimerCopy() ' كود للقيام بعملية حفظ نسخة احتياطية عند مضي مدة على آخر عملية حفظ حسب الوقت الذي يحدده المستخدم ' يمكن استدعاؤه من التايمر في النموذج الرئيس أو في حدث عند إغلاق النموذج الرئيس جرب ضع ( CALL TimerCopy ) في حدث عند الإغلاق في النموذج الرئيسي وأغلق النموذج تجد حفظ نسخة تلقائي من غير تدخل من المستخدم وإيضا تستطيع وضعه في إغلاق البرنامج بشكل عام أو في التايمر بعد مضي وقت معين

السلام عليكم ورحمة الله جرب هذا الكود ربما يفيدك ضع كود الصنف الذى تبحث عنه فى الخلية "E1" قبل استخدام الكود Sub Call_Data() Dim Arr As Variant, Temp As Variant Dim LR As Long, i As Long, j As Long, p As Long Dim ws As Worksheet, Kind As Variant Set ws = Sheets("ورقة1") LR = ws.Range("A" & Rows.Count).End(xlUp).Row Kind = ws.Range("E1").Value ws.Range("E3:G" & LR).ClearContents Arr = ws.Range("A5:C" & LR).Value ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For i = 1 To UBound(Arr, 1) 'On Error Resume Next If Arr(i, 1) = Kind Then p = p + 1 For j = 1 To UBound(Arr, 2) Temp(p, j) = Arr(i, j) Next End If Next If p > 0 Then Range("E3").Resize(p, UBound(Temp, 2)).Value = Temp End Sub

اخوي لايمكن فتح ملف الكبس ؟؟؟😔

تفضل تم التعديل باقرب طريق انظر جدول السعر والاستعلام ثم انظر الشرط في الكود CurConvert1.rar

السلام عليكم ربما هذا يفيد الصق الاكواد في حدث الفورم Private Sub TextBox1_Enter() Application.SendKeys ("%+") End Sub Private Sub TextBox2_Enter() Application.SendKeys ("%+") End Sub