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

تم الوصول إلى جواب لسؤالي عن طريق هذا الرد: https://stackoverflow.com/questions/55523926/font-limitation-in-msaccess-richtext-edit-tool#:~:text=What you can do is to set the,11 in the format toolbar for regular text. وقد قمت بتصميم دالة لحل هذه المشكلة: Function RichTextFontSize(FontSize As Double) As Byte Dim fs As Byte If FontSize <= 8 Then fs = 1 ElseIf Between(FontSize, 9, 10) Then: fs = 2 ElseIf Between(FontSize, 11, 12) Then: fs = 3 ElseIf Between(FontSize, 13, 16) Then: fs = 4 ElseIf Between(FontSize, 17, 22) Then: fs = 5 ElseIf Between(FontSize, 23, 30) Then: fs = 6 Else: fs = 7 End If RichTextFontSize = fs End Function هذا آخرر إصدرا بعد حل باقي المشكلات العالقة: RichTextHighlight_04.accdb

وعليكم السلام ورحمة الله تعالى وبركاته Sub Copy_to_another_workbook() Dim ShData As Worksheet, ShDest As Worksheet Dim aRws As Variant, aCols As Variant, lr As Long Const ShCool As String = "3 4 5 6 7 8 9 10 11 12 13" Set ShData = Worksheets("Sheet1") Application.ScreenUpdating = False 'نفس مسار الملف المفتوح Set ShDest = Workbooks.Open(ThisWorkbook.Path & "\أحمد.xlsm").Sheets("Sheet1") lastrow = ShDest.Cells(ShDest.Rows.Count, "C").End(xlUp).Row + 1 ' لتحديد مسار معين قم بتعديل هدا السطر بما يناسبك ' Set ShDest = Workbooks.Open("C:\Users\MOHAMMED HICHAM\Desktop\أحمد.xlsm").Sheets("Sheet1") lr = ShData.Columns("C:L").Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row aRws = Evaluate("row(10:" & lr + 10 & ")") aCols = Split(ShCool) If ShDest.[C10] = Empty Then ShDest.Range("C10").Resize(lr, UBound(aCols)).Value = Application.Index(ShData.Cells, aRws, aCols) Else ShDest.Range("C" & lastrow).Resize(lr, UBound(aCols)).Value = Application.Index(ShData.Cells, aRws, aCols) End If Workbooks("أحمد.xlsm").Close True Application.ScreenUpdating = True End Sub Saad.rar

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

وعليكم السلام اكتب اول حرف +Ctrlمع الضغط علي زرالمسافه

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

تفضل Sub Copy_My_Data() Dim wsDest As Worksheet Dim LR As Long, LR1 As Long Dim msg As VbMsgBoxResult Dim Rng As Range, wsCopy As Worksheet msg = MsgBox(" ترحيل البيانات الى مصنف أحمد ؟", vbYesNo + vbQuestion + vbDefaultButton2, "تأكيد") If msg = vbYes Then Application.ScreenUpdating = False Set wsCopy = Sheets("Sheet1") With wsCopy LR = .Cells(Rows.Count, 3).End(xlUp).Row Set Rng = .Range(.Cells(10, "C"), .Cells(LR, "L")) End With Set wsDest = Workbooks.Open(ThisWorkbook.Path & "\أحمد.xlsm").Sheets("Sheet9") LR1 = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Row + 1 If wsDest.Range("C10") = Empty Then Rng.Copy wsDest.Range("C10").PasteSpecial Paste:=xlPasteValues Else Rng.Copy wsDest.Range("C" & LR1).PasteSpecial Paste:=xlPasteValues End If Set WS = Workbooks("أحمد.xlsm").Sheets("Sheet1") WCopy = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row WDest = wsDest.Cells(wsDest.Rows.Count, "C").End(xlUp).Offset(1).Row WS.Range("C10:L" & WCopy).Copy wsDest.Range("C" & WDest).PasteSpecial Paste:=xlPasteValues [C10].Select Application.CutCopyMode = False Workbooks("أحمد.xlsm").Close True Application.ScreenUpdating = True End If End Sub Saad2.rar

الشكر لله وحده الحمد لله الذي بنعمته تتم الصالحات، وبفضله تتنزل الخيرات والبركات وبتوفيقه تتحقق المقاصد والغايات

شكراً جزيلاً ...

السلام عليكم ممكن ارفاق المثال

بوركت @AbuuAhmed بقي لك أن تتخلص من رسائل التحديث المزعجة عند كل تحديث يحصل 🙂 وتغيرر هاتين من Long إلى LongPtr لكي تعمل الدالة على النواة 64 بت :

وعليكم السلام هذا فضل توزيع أراه مناسب حسب المعطيات الموجودة repartion2 (1).xlsx

لا تثريب عليك أخي العزيز @أبو إبراهيم الغامدي 😄✋🏻 بالعكس استفدت من طريقتك وتعلمت أسلوب جديد 👍🏼😁

استخدم الكود التالي Dim strSql As String Dim qdf As QueryDef strSql = "SELECT id, idara, lagnano, lagna, " & Combo0 & " FROM stu WHERE idara ='" & Combo2 & "'" On Error Resume Next DoCmd.DeleteObject acQuery, "stu Query" Set qdf = CurrentDb.CreateQueryDef("stu Query", strSql) DoCmd.OpenQuery qdf.Name qdf.Close Set qdf = Nothing مرفق المثال بعد التعديل stu.accdb

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

وافي ما قصرت الحمدلله نلت المطلوب كثر الله خيرك أستاذنا الغالي السموحة تعبتك معي تحياتي

اتفضل ي استاذ @الفارس محمد رجب جرب هذا الكود Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If Shift = (vbCtrlMask Or vbShiftMask) Then Unload Me End If End Sub ودا كود تعطيل زر جرب Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then Cancel = True MsgBox "تم تعطيل زر الإغلاق!", vbInformation, "تحذير" End If End Sub

تفضل أخي مصطفى، هذا ماكرو لترتيب أبيات شعرية في جدول من خلال الورد: ' ' 'ماكرو ترتيب أبيات شعرية في جدول، ولا بد أن يكون هناك جدول فقط ' On Error Resume Next If Len(Selection.Text) = 1 Then MsgBox "من فضلك ظلل عمود الشطر الثاني الذي فيه القافية" Exit Sub End If Selection.Font.Color = 10498160 Selection.MoveLeft Unit:=wdCharacter, Count:=1 For i = 1 To 100000 Selection.EndKey Unit:=wdLine Selection.Find.ClearFormatting Selection.Find.Font.Color = 10498160 Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "^$" .Replacement.Text = "" .Forward = False .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Selection.MoveRight Unit:=wdCharacter, Count:=1 Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend Selection.Copy Selection.SelectRow Selection.Font.Color = wdColorAutomatic Selection.HomeKey Unit:=wdLine Selection.PasteAndFormat (wdPasteDefault) Selection.HomeKey Unit:=wdLine, Extend:=wdExtend If Selection.Font.Underline = wdUnderlineNone Then Selection.Font.Underline = wdUnderlineSingle Else Selection.Font.Underline = wdUnderlineNone End If Selection.Find.ClearFormatting With Selection.Find.Font .Underline = wdUnderlineSingle .Color = 10498160 End With Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "[ًٌٍَُِّْ]" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll Selection = StrReverse(Selection) Selection.HomeKey Unit:=wdLine Selection.MoveDown Unit:=wdLine, Count:=1 Selection.Find.ClearFormatting With Selection.Find.Font .Underline = wdUnderlineNone .Color = 10498160 End With Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "^$" .Replacement.Text = "" .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Selection.MoveLeft Unit:=wdCharacter, Count:=1 If Selection.Find.Found = False Then Exit For End If Next i Selection.HomeKey Unit:=wdStory Selection.Find.ClearFormatting With Selection.Find.Font .Underline = wdUnderlineSingle .Color = 10498160 End With Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = " [اويى]" .Replacement.Text = " " .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = True .MatchControl = False .MatchAllWordForms = False .MatchSoundsLike = False .MatchWildcards = True End With Selection.Find.Execute Replace:=wdReplaceAll Selection.Find.Execute Replace:=wdReplaceAll Selection.Find.Execute Replace:=wdReplaceAll Selection.Sort ExcludeHeader:=False, FieldNumber:="عمود 1", SortFieldType _ :=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, FieldNumber2 _ :="", SortFieldType2:=wdSortFieldAlphanumeric, SortOrder2:= _ wdSortOrderAscending, FieldNumber3:="", SortFieldType3:= _ wdSortFieldAlphanumeric, SortOrder3:=wdSortOrderAscending, Separator:= _ wdSortSeparateByCommas, SortColumn:=False, CaseSensitive:=False, _ LanguageID:=wdArabic, SubFieldNumber:="فقرات", SubFieldNumber2:="فقرات", _ SubFieldNumber3:="فقرات" Selection.Sort BidiSort:=False, IgnoreThe:=True, IgnoreKashida:=False, _ IgnoreDiacritics:=False, IgnoreHe:=False Selection.Find.ClearFormatting With Selection.Find.Font .Underline = wdUnderlineSingle .Color = 10498160 End With Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "" .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = False .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll Selection.HomeKey Unit:=wdStory Beep MsgBox "تم ترتيب الشعر بنجاح" End Sub

وعليكم السلام -يمكنك تحميل هذا من هنا فلا يحتاج الى تفعيل https://www.4shared.com/rar/vx1cv9Hxca/KutoolsforExcel1650.html وهذا رابط اخر http://www.mediafire.com/file/xcvjc4oywbvonda/Kutools.for.Excel.16.50.rar/file

بسم الله الرحمن الرحيم الحمد لله الواحد القهار، العزيز الغفار، مكور الليل على النهار ، تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ، الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار، وشغلهم بمراقبته وإدامة الأفكار ، وملازمة الاتعاظ والاذكار، ووفقهم للدؤوب في طاعته والتأهب لدار القرار، والحذر مما يسخطه ويوجب دار البوار، والمحافظة على ذلك مع تغاير الأحوال والأطوار. أحمده أبلغ حمد وأزكاه، وأشمله وأنماه. أما بعد: رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته ولذا رأيت أنا الفقير إلى الله المحمدي عبد السميع عبد الغني أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ، ولهذا ساقدم سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له في موضوع مستقل وسأشرح كيفية استخدام الكود ماتيسر لي إن شاء الله وعلى الله قصد السبيل ****************************************** هذا كود التنقل الى اي صفحة في ملف اكسيل طريقة الاستفادة من الكود افتح ملف اكسيل اضغط على الرز ALT وانت ضاغط على الزر اضغط على F11 الموجود أعلا لوحة المفاتيح ستظهر شاشة الماكرو اضغط على موديول 1 سيتم فتح الموديول الصق فيه الكود الموجود تحت هذا السطر [/center] ' ' هذا الكود للعالم العلامة عبد الله باقسير Sub GO_TO() On Error Resume Next Application.CommandBars("Workbook Tabs").Controls("More Sheets...").Execute If Err.Number > 0 Then Err.Clear Application.CommandBars("Workbook Tabs").ShowPopup End If Activewindow.ScrollColumn = 1 Activewindow.ScrollRow = 1 On Error GoTo 0 End Sub في هذا الكود البسيط والمفيد عند الضغط على الزر ستنسدل قائمة بأسماء كل الصفحات الموجوده بالملف اختر منها الورقة التي تبعاها ودمتم في حفظ الله التنقل بين الصفحات.rar

السلام عليكم هذا الكود ليس من اعمالي وانما استخدمته كثيرا في اعمالي ملحوظة: يكفي هذا السطر من الكود ليقوم بذلك Sub SheetList_CP() Application.CommandBars("Workbook Tabs").ShowPopup End Sub تحياتي

جزاك الله خيرا استاذ محمدي عبد السميع وها كود مع اختصار بعض الاسطر Sub SheetList_CP() On Error Resume Next Application.CommandBars("Workbook Tabs").Controls("More Sheets...").Execute If Err.Number > 0 Then Err.Clear Application.CommandBars("Workbook Tabs").ShowPopup End If On Error GoTo 0 End Sub