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

من فضلك عليك الإنتباه من هذه الأخطاء ... فهذا الخطأ منك انت لأنك قمت بذكر صفحة Data بأكواد الفورم على الرغم انها غير موجودة بالملف المرفوع فعندما قمت بإضافة هذه الصفحة تم ظهور الفورم بكل كفاءة حل مشكلة1.xlsm

من فضلك اخى الكريم لا تبخل بنجاح المشاركة فليس هناك وجود لأى مشاركة الا بعد تدعيمها بملف مشروح فيه كل المطلوب بكل دقة والا فكان عليك لزاماً استخدام خاصية البحث بالمنتدى قبل رفع هذه المشاركة طالما انك لم تقم برفع ملف !!! ولا تقول ان المشاركة بسيطة لا تحتاج لكل هذا ... فان كان طلبك بسيط لأستطعت انت بنفسك حله ولا احتجت لمساعدة الأخرين فى حل مشكلتك وتفريج كربتك تفضل هذا الكود Sub Unhide_All_Sheets() Dim ws As Worksheet ActiveWorkbook.Unprotect For Each ws In Worksheets ws.Visible = xlSheetVisible Next End Sub وهذا كود أخر Sub Unhide_All_Sheets_Count() Dim wks As Worksheet Dim count As Integer count = 0 For Each wks In ActiveWorkbook.Worksheets If wks.Visible <> xlSheetVisible Then wks.Visible = xlSheetVisible count = count + 1 End If Next wks If count > 0 Then MsgBox count & " worksheets have been unhidden.", vbOKOnly, "Unhiding worksheets" Else MsgBox "No hidden worksheets have been found.", vbOKOnly, "Unhiding worksheets" End If End Sub وهذا كود ثالث Sub Unhide_Selected_Sheets() Dim wks As Worksheet Dim MsgResult As VbMsgBoxResult For Each wks In ActiveWorkbook.Worksheets If wks.Visible = xlSheetHidden Then MsgResult = MsgBox("Unhide sheet " & wks.Name & "?", vbYesNo, "Unhiding worksheets") If MsgResult = vbYes Then wks.Visible = xlSheetVisible End If Next End Sub وهذا كود رابع Sub Unhide_Sheets_Contain() Dim wks As Worksheet Dim count As Integer count = 0 For Each wks In ActiveWorkbook.Worksheets If (wks.Visible <> xlSheetVisible) And (InStr(wks.Name, "report") > 0) Then wks.Visible = xlSheetVisible count = count + 1 End If Next wks If count > 0 Then MsgBox count & " worksheets have been unhidden.", vbOKOnly, "Unhiding worksheets" Else MsgBox "No hidden worksheets with the specified name have been found.", vbOKOnly, "Unhiding worksheets" End If End Sub اختر منهم ما يناسبك عرفت ان كده اهدار للوقت لأنك لم تقم من البداية برفع الملف فالخطأ عندك ,فالملف لم تقم بوضع اى كود به-تفضل بعد وضع الكود يعمل بكل كفاءة مثال.xlsm

بارك الله فيك استاذ محي ولإثراء الموضوع يمكنك استخدام هذه المعادلة المعرفة وهذا هو كودها Function Evals(t As String) As Double Dim c As String, i As Long For i = 1 To Len(t) If Asc(Mid(t, i, 1)) < 58 And Asc(Mid(t, i, 1)) > 41 Then c = c & Mid(t, i, 1) Next Evals = Evaluate(c) End Function ثم تكتب المعادلة بالخلية B2 على النحو التالى : =Evals(A2) سليم1.xlsm

ما رأيك بهكذا سليم.xlsm

جرب هذا Book1.xlsm

تفضل -يمكنك استخدام هذه المعادلة =COUNTIFS($B$4:$B$28,I$4,$C$4:$C$28,"*"&$H5&"*") SAME1.xlsx

جرب هذا الملف Ab_Kassem.xlsx

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

شرف كبير الحديث معكم أخي الحبيب أبو عاصم، وأسأل الله تعالى أن يجعل في ذلك الفائدة والنفع والأجر للجميع. بخصوص الحديث النبوي الشريف: أنا معك، يمكن العمل على ذلك، والنتائج ستكون صحيحة بنسبة 100%، حيث يمكن إضافة الكتب التسعة، وبذلك سيتم معالجة قسم كبير من الأحاديث، والأحاديث المخرجة في الكتب التسعة سيتم معالجتها ومعالجة كل العبارات المأخوذة منها. هل لك أخي العزيز أن تطلعنا على القائمة التي تحوي آلاف الجمل، والتي ذكرت أنكم قمتم باستخراجها؟

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

مرحبا اخي يفضل ارفاق مثال لكي نقوم بي العمل عليه وتحدد المسارات التي تريدها

وعليكم السلام ورحمة الله وبركاته أهلاً وسهلاً بك أخي وأستاذي العزيز أبو عاصم المصري، وبعد: أنت أحد الأشخاص الذين أعتبر ملاحظاتهم واقتراحاتهم في إضافة البيان البحثية هي بمثابة أمر عليَّ تنفيذه، والله شهيد على ذلك؛ وهذا بسبب خبرتكم العريقة في مجال البحث والتحقيقات، فأنتم تطرحون عصارة أفكاركم وتجاربكم، وهذا كله يخدم الباحثين؛ وهذا ما دفعني لتنفيذ كل الاقتراحات. أما بخصوص التشكيل الآلي: طريقتك جيدة ومميزة، وأنا شخصياً أستفيد منها، وخاصة في أسماء الأعلام، حيث أرجع إلى النسخة المحققة والمشكولة من «سير أعلام النبلاء» لأقوم بضبط أسماء الأعلام، ولكن للأسف لا يمكن تعميمها وتطبيقها؛ للأسباب التالية: 1- التشكيل الآلي يحتاج لذكاء اصطناعي، وحتى الذكاء الاصطناعي فشل في عملية التشكيل 100%. 2- سأحتاج لإضافة الكثير من الكتب، وهذا العمل سيجعل حجم الإضافة كبيراً للغاية، وهو ما جعل إضافة الدكتور العقيل حوالي 2 غيغا عندما أضاف الدواوين الشعرية من أجل تخريج الأبيات. 3- الكتب التي نريد الاعتماد عليها، قد يوجد فيها بعض الأخطاء، وخاصة وأنها نسخ إلكترونية، وحتى تلك الموجودة في المكتبة الشاملة لا تخلو من هذه الأخطاء، وهذا الكلام عن تجربة. 4- سأتعرض لنقد شديد من مستخدمي الإضافة، وسيضيف كل شخص طريقة يراها مناسبة من وجهة نظره، وسينتقد طريقة غيره، وفي النهاية سيكون العمل شائكاً لا يُرضي أي طرف. لذلك أضفت خاصية الاستبدال المتعدد، بحيث تعين في تصحيح الأخطاء، ويمكن مستقبلاً إضافة كتب السنة السبعة وغيرها من كتب المتون؛ ليتم تصحيح الأحاديث وتشكيلها آلياً، وخدمة القرآن الكريم حالياً تصحح أخطاء الآيات في الرسم الإملائي وتقوم بتشكيلها آلياً، وقريباً إن شاء الله تعالى سأضيف بعض الخدمات المتعلقة بخاصية التصحيح التلقائي الموجودة في Word، من حيث استيراد عبارات التصحيح التلقائي، وإضافة عبارات كثيرة موجودة ضمن جدول دفعة واحدة. بخصوص إيقاف عملية معينة: أغلب العمليات تتم بشكل سريع، ولكن في خدمة القرآن الكريم أنت محق؛ فقد جربت أن أضيف القرآن الكريم كاملاً ثم قمت باستبداله للرسم العثماني فاستغرق الأمر حوالي ربع ساعة؛ لذا سأفكر بهذا الأمر في التطويرات القادمة إن شاء الله تعالى. وبخصوص رسالة [موافق - تجاهل] يمكنك تعطيل خيار (تنبيه عند وجود خطأ في الآية)، وكذلك تعطيل خيار (تنبيه عند وجود أكثر من تخريج للآية) وبهذا لن تخرج لك أي رسالة خطأ. أشكرك جداً أخي الحبيب على ملاحظاتك القيمة، وثق تماماً أنني أسعى لتطبيقها بأبهى صورة وأفضل أداء يخدم الباحث.

الأستاذ شحادة، السلام عليكم ورحمة الله وبركاته. هل هناك طريقة لإيقاف عملية معينة أو إلغائها؟ وذلك أني طلبت تغيير آيان في ملف كبير للخط العثماني، وكان أغلب الآيات محولة بالفعل، وكلما مر على ما بين القوسين {} أخرج رسالة [موافق - تجاهل]؟ وهذا كان من باب الاختبار فقط، بقصد تطوير هذه الإضافة الجميلة. أرجو المعذرة، فهذا العمل رائع، وإن شاء الله بعد فترة من التطوير الذي تقوم به، سيكون من أفضل ما يقدم للباحثين.

بعد اذن الاخ علي لا يتم الترتيب الا اذا 1-كان هناك بيانات في الأعمدة B / C / D ( الترقيم لا ضرورة له لانه يتم اوتوماتيكياً) 2- تمت الكتابة في اول صف غير فارغ Option Explicit Dim RG As Range, Ro '++++++++++++++++++++++++++++++++++ Private Sub Worksheet_Change(ByVal Salim As Range) Set RG = Range("A2").CurrentRegion Ro = RG.Rows.Count With Application .EnableEvents = False .Calculation = xlCalculationManual .ScreenUpdating = False End With If Ro = 1 Then GoTo Bay_Bay If Salim.Row = Ro + 1 And _ Application.CountA(Cells(Salim.Row, 2) _ .Resize(, 3)) = 3 Then RG.Sort Range("D2"), 2, Header:=1 With RG.Offset(1).Resize(Ro - 1) .Columns(1) = Evaluate("row(1:" & Ro - 1 & ")") .HorizontalAlignment = 1 .InsertIndent 1 .Font.Size = 18 .Font.Bold = True .Borders.LineStyle = 1 End With End If Bay_Bay: With Application .EnableEvents = True .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub الملف مرفق Auto_sort.xlsm

وعليكم السلام يمكنك هذا ,بوضع ذلك الكود بحدث الصفحة Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next If Not Intersect(Target, Range("d:d")) Is Nothing Then Range("d1").Sort Key1:=Range("d2"), _ Order1:=xlDescending, Header:=xlYes, _ OrderCustom:=1, MatchCase:=False, _ Orientation:=xlTopToBottom End If End Sub فرز حسب 1الاكبر.xlsm

تجربتي مع التشكيل الآلي: يعتبر التصحيح من أكثر مراحل العمل العلمي التي تأخذ وقتا وجهدا كبيرا، وخصوصا إذا كان تشكيلا شاملا لكل الكلمات. وكنت قد لجأت لطريقة بدائية اعتمدت عليها في ضبط كثير من المجلدات بالشكل الكامل، وكانت النتيجة مرضية بشكل كبير، ولا يعني هذا عدم تدخل المصحح، بل لا بد أن يقوم بعملية التصحيح المعروفة، وقد وفر هذا جهدا كبيرا، مع دقة عالية. عملت الماكرو كالتالي: 1- أحضرت ملفا مشكولا بصورة كاملة، جمعت فيه كتابا لغويا (مثل تاج العروس، أو لسان العرب)، وكتابا حديثيا (مثل مسند الإمام أحمد)، وكتابا في التفسير (مثل تفسير الطبري)، وكتابا فقهيا (مثل المغني لابن قدامة)، وكتابا أصوليا (مثل البرهان للجويني)، وكتاب تاريخيا، وكتابا أدبيا، ويمكن أن يضاف كتب أخرى. 2- فتحت الملف المراد تصحيحه، ونسخت أول أربع كلمات، وبحثت عنها في الملف المشكول، فإذا وجدها نسخها، وقمت باستبدالها في الملف كله ولونتها باللون الأحمر لتمييزها. 3- نسخت الكلمة الثانية إلى الخامسة، ثم الثالثة إلى السادسة، وهكذا، فما وجده في الملف المشكول، نسخته في الملف المراد تصحيحه في كل المواضع. 4- وكانت النتيجة عالية جدا. * جمعت قائمة بحروف لا تجتمع أبدا، وإذا حدث ذلك علمت على الكلمة. * جمعت قائمة أخرى بتشكيل لا يتوالى أبدا مثل (سكون، بعده سكون)، (شده بعدها سكون). * فما كان كذلك ظللته ليراجعه المصحح. فلو رأيت أن تضيف مثل هذا (لإضافة البيان الرائعة) كان في هذا خير عظيم، وفائدة كبيرة. ويمكن أن تجعلها تحت التجربة، للاستفادة من آراء الإخوة. بارك الله فيك أخانا الحبيب، وأرجو ألا أكون قد أثقلت عليك.

نعم هذا هو المطلوب تماما بوركت وبارك الله في علمك

جرب المرفق fik.xlsm

جرب هذا الكود ولكن يجب ان تكون مسميات الشيتات كما في العمود (i) Sub Envoier_donner() Dim sh As Worksheet Dim ws As Worksheet Set ws = Sheets("التقرير") Dim lr1, lr2, x, x2 Application.ScreenUpdating = False For Each sh In ThisWorkbook.Worksheets lr1 = ws.Cells(Rows.Count, 2).End(3).Row For x = 11 To lr1 If ws.Cells(x, "i").Text = sh.Name Then lr2 = sh.Cells(Rows.Count, 2).End(3).Row + 1 sh.Range("b" & lr2).Resize(1, 12).Value = ws.Cells(x, 2).Resize(1, 12).Value End If Next x Next sh Application.ScreenUpdating = True End Sub fik.xlsm

تفضل اخي الكريم اريد اظهار المرفق المرتبط.accdb

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

جرب هذا التعديل وان شاء الله المحاولة تكون موفقة Search&Sort-3.rar

تفضل التعديل استاذ alsihran ارجو ان يكون طلبك التنسيق الشرطي-2.rar

جرب المرفق 100.xlsm

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

السلام عليكم ورحمة الله وبركاته اساتذتي الاعزاء شفان الريكاني و kanory المحترمين شكرا جزيلا على الجهود التي بذلتموها وكانت الاجابات متقاربه وقريبه من تحقيق المطلوب جزاكم الله عنا خير الجزاء الاستاذ husamwahab جزاك الله عنا خير الجزاء وجعل ذلك في ميزان حسناتك . وفيت وكفيت . تحياتي لك اخي العزيز

الظاهر ان المشكلة عندك في الــ Windows جرب ان تنفذ الماكرو من جهاز اخر او دع احد غيرك يحمل الملف ويجربه

وعليكم السلام-تفضلى goto the page with pass1.xls

وعليكم السلام -يمكنك استخدام هذه المعادلة لذلك ... وأيضاً بالملف يوجد أربعة معادلات أخرى =LOOKUP(1,0/('1'!$A$3:$A$600=$A3)/('1'!$B$3:$B$600=$B3),'1'!$C$3:$C$600) test match price1.xlsx

وعليكم السلام-لكى يتحقق ما تريد عليك بإستخدام هذه المعادلة =(INT(A2)+(A2-INT(A2))*100/60)*C2 الأضافى1.xls

تم التعديل على الملف قليلا من حيث المظهر والتنسيق Option Explicit Sub MY_code() Rem Created by Salim Hasbaya On 19/10/2020 Application.ScreenUpdating = False Dim B As Worksheet, Tas As Worksheet Dim arr() Dim i%, t%, col%, p%, n%, Q%, LB% Dim St$, itm As Variant Dim Rg As Range Set B = Sheets("البيان") Set Tas = Sheets("التصنيفات") Set Rg = Tas.Range("B1").CurrentRegion If Rg.Rows.Count = 1 Then GoTo Ma_Lish_Da3wa Set Rg = Rg.Offset(1).Resize(Rg.Rows.Count - 1) LB = B.Cells(Rows.Count, 2).End(3).Row B.Range("D2").CurrentRegion.ClearContents If LB = 1 Then GoTo Ma_Lish_Da3wa For i = 1 To Rg.Cells.Count If Rg.Cells(i) <> "" Then ReDim Preserve arr(t) arr(t) = Rg.Cells(i) t = t + 1 End If Next t = 2 B.Range("D2").Resize(LB - 1) = _ B.Range("B2").Resize(LB - 1).Value '+++++++++++++Creating The Data +++++++++++++ For i = 2 To LB If B.Range("D" & i) <> vbNullString Then For Each itm In arr If InStr(B.Range("D" & i), itm) Then col = Rg.Find(itm, lookat:=1).Column St = Replace(B.Range("D" & i), itm, "*") col = Rg.Find(itm, lookat:=1).Column St = Replace(St, "*", Tas.Cells(1, col)) B.Range("D" & i) = St End If Next itm End If Next i '+++++++++++++ End Of Creating The Data +++++++++++++ Erase arr ReDim arr(1 To 3) For i = 1 To 3 arr(i) = Tas.Cells(1, i + 1) Next p = 1 '+++++++++++++Formating with Red Color +++++++++++++ For i = 2 To LB For Each itm In arr Do Q = InStr(p, B.Range("D" & i), itm) If Q = 0 Then Exit Do n = InStr(Q, B.Range("D" & i), " ") p = p + n + 1 B.Range("D" & i).Characters(Q, n - Q). _ Font.ColorIndex = 3 Loop p = 1 Next itm Next i '++++++++++++++End Of Formating with Red Color +++++++++++++ Ma_Lish_Da3wa: Set B = Nothing: Set Tas = Nothing Set Rg = Nothing: Erase arr Application.ScreenUpdating = True End Sub الملف من جديد مع الكودين القديم والجديد Mh_Fayz _New.xlsm

وعليكم السلام-لك ما طلبت test search1.xlsx

ضع الكود ده .. في مودول .. وجرب ان شاء الله يفي بالغرض ... Option Explicit Sub Print_by_number() 'في حالة الطباعة بدون معاينة Dim m As Integer m = InputBox("كم نسخة تريد طباعتها : ", "اوفيسنا ") ActiveSheet.PrintOut Copies:=m, Collate:=True Range("b5").Activate End Sub Sub Print_by_number2() 'في حالة الطباعة بمعاينة Dim m As Integer m = InputBox("كم نسخة تريد طباعتها : ", "اوفيسنا ") ActiveSheet.PrintOut Copies:=m, Preview:=True, Collate:=True Range("b5").Activate End Sub

اتفضل استاذ اليك هذا Public Sub OpenDocument(DocPath As String) Dim A As Long A = Shell("RUNDLL32.EXE URL.DLL,FileProtocolHandler " & DocPath, vbMaximizedFocus) End Sub Private Sub Command1_Click() Call OpenDocument("C:\Users\Shivan\Desktop\TEST.pdf") End Sub

اخواني الكرام اضع بين ايديكم الجزء الاول من شرح الترحيل وبإنتظار تعليقاتكم واستفسارتكم ابواحمد الجزء الاول من الشرح ملف شرح الجزء الاول الترحيل.rar الجزء الثاني من الشرح ملف شرح الجزء الثانى الترحيل2.rar الجزء الثالث من الشرح (ترحيل القيم - ترحيل محدوود) ملف شرح الجزء الثالث الترحيل3.rar الجزء الرابع من شروحات الترحيل ملف شرح الجزء الرابع ترحيل حسب اسم الشيت.rar لا تنسوني أخوتي من الدعاء لي بظهر الغيب

اضف الكلمة PtrSafe للتصريحات .. بمعني Public Declare PtrSafe Function بدلا من Public Declare Function PtrSafe توضع عند استخدام اوفيس 46 بت

زيادة في اثرء الموضوع يمكن استعمال اح هذين الكودين: Sub salim() i = 2 Do While Range("a" & i) <> "" Range("B" & i) = "=" & Range("a" & i) i = i + 1 Loop End Sub

أخي الكريم سليم جرب الكود بهذا الشكل Sub DoIt() Dim Cell As Range For Each Cell In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) Cell.Offset(, 1) = "=" & Cell.Value Next Cell End Sub إن شاء الله تظبط معاك تقبل تحياتي

شكرا جزيلا على هذا الكود الرائع بعد اذن حضرتك عملت تعديل على الكود بحيث يخفي الصفوف الفارغة - أو يظهرها مرة أخرى Sub ss() Application.ScreenUpdating = False For i = 5 To 100 If Mid(Cells(i, 1), 1, 1) = "" Then Cells(i, 1).Value = "" End If Next i Range("A5:A100").Select Selection.SpecialCells(xlCellTypeBlanks).Select Selection.EntireRow.Hidden = True Range("A1").Select Application.ScreenUpdating = False End Sub Sub ss2() Application.ScreenUpdating = False For i = 5 To 100 If Mid(Cells(i, 1), 1, 1) = "" Then Cells(i, 1).Value = "" End If Next i Range("A5:A100").Select Selection.SpecialCells(xlCellTypeBlanks).Select Selection.EntireRow.Hidden = False Range("A1").Select Application.ScreenUpdating = False End Sub ss اخفاء ss2 اظهار شكرا إخفاء وإظهار الصفوف التي الفارغة.rar