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

وعليكم السلام-تفضل هذا الكود Sub PrintPDF() Call Save_PDF End Sub Function Save_PDF() As Boolean Dim Thissheet As String, ThisFile As String, PathName As String Dim SvAs As String Application.ScreenUpdating = False Thissheet = ActiveSheet.Name ThisFile = ActiveWorkbook.Name PathName = ActiveWorkbook.Path SvAs = PathName & "\" & Thissheet & ".pdf" On Error Resume Next ActiveSheet.PageSetup.PrintQuality = 600 Err.Clear On Error GoTo 0 On Error GoTo RefLibError ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=SvAs, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=True On Error GoTo 0 SaveOnly: MsgBox "A copy of this sheet has been successfully saved as a .pdf file: " & Chr(13) & Chr(13) & SvAs & _ "Review the .pdf document. If the document does NOT look good, adjust your printing parameters, and try again." Save_PDF = True GoTo EndMacro RefLibError: MsgBox "Unable to save as PDF. Reference library not found." Save_PDF = False EndMacro: End Function وتم تجربة الكود على الطابعة , يعمل بنجاح وهذا هو الدليل قمت بعمل سكان لك للورقتين Scan1.pdf Scan2.pdf A4 VERSION1.xlsm

صديقى انا وضعت لك كود (جسب طلبك) ولست مسؤولاً عن ما يضعه الغير ان كان صحيحاً ام لا

ارفع الملف نفسه لا يمكن التعامل مع صورة

حيث أنك لم ترقع ملف للمعاينة جرب هذا الملف Fuction_split_name.xlsm

الف شكر استاذي husamwahab وكل من ساهم في مساعدتي واسال الله تعالى لكم جميعا التوفيق

تفضل لا يمكنك العمل بهذه الدالة قبل 1900 ولكن هناك دالة معرفة وهى XDATEYEARDIF ..... وهذا هو كودها Function XDATEYEARDIF(xdate1, xdate2) As Long Dim YearDiff As Long Dim i As Long, D1 As String, D2 As String D1 = xdate1 For i = 1 To 7 D1 = Replace(D1, Format(i, "dddd"), "") D1 = Replace(D1, Format(i, "ddd"), "") Next i D2 = xdate2 For i = 1 To 7 D2 = Replace(D2, Format(i, "dddd"), "") D2 = Replace(D2, Format(i, "ddd"), "") Next i YearDiff = Year(D2) - Year(D1) If DateSerial(Year(D1), Month(D2), Day(D2)) < CDate(D1) Then YearDiff = YearDiff - 1 XDATEYEARDIF = YearDiff End Function اشخاص - 1.xlsm

تمام، بارك الله فيك أخانا شحادة

حبيبنا الأستاذ مصطفى، أسعدني ردكم، وللعلم فإني قد استفدت كثيرا من مشاركاتك أنت والأستاذ شحادة، وغيركما من الإخوة الأعضاء، فأسأل الله أن يجعل هذا في ميزان حسناتكم. وبالفعل ملحوظتك بخصوص زيادة (ابن أبي) صحيحة، وقد زدتها مع (ابنة) ، (ابنة أبي)، وهذا الماكرو بعد هذه الإضافات: Sub ترتيبفيجدول() ' ' ترتيبفيجدول Macro 'ماكرو لترتيب قائمة أعلام أو قبائل في جدول مع عدم اعتبار أبو، ابن، أم، بنو في الترتيب ' Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Font.Hidden = True With Selection.Find .Text = "ابن أبي" .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = False .MatchWholeWord = False .MatchKashida = False .MatchDiacritics = False .MatchAlefHamza = True .MatchControl = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = "ابنة أبي" .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = True .MatchAlefHamza = True .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = "ابن " .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = True .MatchAlefHamza = True End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = "ابنة " .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = True .MatchAlefHamza = True End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = "أبو " .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = True .MatchAlefHamza = True End With Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = "أم " .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = True .MatchAlefHamza = True End With Selection.Find.Execute Replace:=wdReplaceAll Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Font.Hidden = True With Selection.Find .Text = "بنو " .Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = True .MatchAlefHamza = True End With 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:=wdArabicEgypt, SubFieldNumber:="فقرات", SubFieldNumber2:= _ "فقرات", SubFieldNumber3:="فقرات" Selection.Sort BidiSort:=False, IgnoreThe:=True, IgnoreKashida:=False, _ IgnoreDiacritics:=False, IgnoreHe:=False With Selection.Font .Name = "AAA GoldenLotus" .Size = 16 .Bold = False .Italic = False .Underline = wdUnderlineNone .UnderlineColor = wdColorAutomatic .StrikeThrough = False .DoubleStrikeThrough = False .Outline = False .Emboss = False .Shadow = False .Hidden = False .SmallCaps = False .AllCaps = False .Color = wdColorAutomatic .Engrave = False .Superscript = False .Subscript = False .Spacing = 0 .Scaling = 100 .Position = 0 .Kerning = 0 .Animation = wdAnimationNone .SizeBi = 16 .NameBi = "AAA GoldenLotus" .BoldBi = False .ItalicBi = False .Ligatures = wdLigaturesNone .NumberSpacing = wdNumberSpacingDefault .NumberForm = wdNumberFormDefault .StylisticSet = wdStylisticSetDefault .ContextualAlternates = 0 End With Selection.MoveUp Unit:=wdLine, Count:=1 End Sub

مشاركة مع اساتذتي الاجلاء استاذ محمد أبوعبدالله واستاذ ابوخليل ملاحظة : التعديل حسب ما طلبت بالاضافة الا انه يتقبل اكثر من مجموعتين Root300.rar

تم التعديل كما تريدين الأعداد السالبة تظهر باللون الأصفر والموجبة بالأخضر(شرط تطابق التاريخ) حلايا التاريخ المطلوب باللون الزهري Option Explicit Sub get_special_columns() Dim D As Worksheet Dim Sh As Worksheet Dim Ar(), Min_date As Date, Max_date As Date Dim K%, t%, Arr_sh() Dim My_ro%, m%, ro%, my_sum#, x% Dim Sum_pos#, Sum_Neg# K = 2 Set D = Sheets("DataReport") D.Rows.Hidden = False If D.Range("A3").CurrentRegion.Rows.Count > 1 Then D.Range("A3").CurrentRegion.Offset(1). _ Resize(D.Range("A3").CurrentRegion.Rows.Count - 1).Clear End If If Not IsDate(D.Range("J2")) Or _ Not IsDate(D.Range("K2")) Then Exit Sub Min_date = Application.Min(D.Range("J2:K2")) Max_date = Application.Max(D.Range("J2:K2")) Ar = Array("E", "F", "G", "H", "I", "J") For Each Sh In Sheets If Sh.Tab.ColorIndex = D.Range("N1") Then ReDim Preserve Arr_sh(m) Arr_sh(m) = Sh.Name: m = m + 1 End If Next Sh If m = 0 Then Exit Sub For m = LBound(Arr_sh) To UBound(Arr_sh) D.Cells(K, 1) = Arr_sh(m) D.Cells(K + 1, 1) = "Total " & D.Cells(12, "J") D.Cells(K + 1, 1).Resize(, UBound(Ar) + 2).Interior.ColorIndex = 20 K = K + 2 Next m My_ro = 3 For m = LBound(Arr_sh) To UBound(Arr_sh) Set Sh = Sheets(Arr_sh(m)) Sh.Range("A5:J20000").Interior.ColorIndex = xlNone ro = Sh.Cells(Rows.Count, 1).End(3).Row For K = LBound(Ar) To UBound(Ar) t = K + 2 For x = 5 To ro If Sh.Cells(x, 1) <= Max_date _ And Sh.Cells(x, 1) >= Min_date Then Sh.Cells(x, 1).Interior.ColorIndex = 40 If Val(Sh.Cells(x, Ar(K))) <> 0 Then my_sum = my_sum + Sh.Cells(x, Ar(K)) '+++++++++++++++++++++++++++++ If Val(Sh.Cells(x, Ar(K))) <= 0 Then Sum_Neg = Sum_Neg + Val(Sh.Cells(x, Ar(K))) Sh.Cells(x, Ar(K)).Interior.ColorIndex = 6 Else Sum_pos = Sum_pos + Val(Sh.Cells(x, Ar(K))) Sh.Cells(x, Ar(K)).Interior.ColorIndex = 35 End If '++++++++++++++++++++++++++ End If End If Next x Select Case D.Cells(12, "J") Case "Positive" D.Cells(My_ro, t) = Sum_pos Case "Nagative" D.Cells(My_ro, t) = Sum_Neg Case Else D.Cells(My_ro, t) = my_sum End Select my_sum = 0: Sum_pos = 0: Sum_Neg = 0 Next K My_ro = My_ro + 2 Next m D.Cells(My_ro, 1) = "Sum Of All" Rem D.Cells(My_ro - 1, 2).Resize(, UBound(Ar) + 1) = Ar With D.Cells(My_ro - 1, 2).Resize(, 6) .Value = D.Cells(1, 2).Resize(, 6).Value .Interior.Color = vbBlue .Font.Color = vbWhite End With D.Cells(My_ro, 2).Resize(, UBound(Ar) + 1).Formula = _ "=Sum(B3:B" & My_ro - 2 & ")" D.Cells(My_ro, 1).Resize(, UBound(Ar) + 2).Interior.ColorIndex = 6 If D.Range("A3").CurrentRegion.Rows.Count > 1 Then With D.Range("A3").CurrentRegion.Offset(1). _ Resize(D.Range("A3").CurrentRegion.Rows.Count - 1) .Borders.LineStyle = 1: .Font.Size = 14 .Font.Bold = True: .HorizontalAlignment = xlCenter .Value = .Value End With End If For m = My_ro - 2 To 3 Step -1 If D.Cells(m, 1) Like "Total*" And _ Application.Sum(D.Cells(m, 2).Resize(, 6)) = 0 Then D.Range(Cells(m, 1), Cells(m - 1, 1)).EntireRow.Hidden = True End If Next End Sub '++++++++++++++++++++++++++++++ Sub show_all() Sheets("DataReport").Rows.Hidden = False End Sub الملف مرفق Yara_Pos_Neg_All.xlsb

وعليكم السلام ورحمة الله وبركاته تفضل اخي الكريم On Error GoTo Err: If IsNull(Me.txtClassCnt) Then MsgBox "ادخل عدد المجموعات اولاً" Exit Sub Else X = Round(Me.Form.Recordset.RecordCount / 2 + 0.5) DoCmd.GoToRecord , , acFirst I = 0 Do I = I + 1 J = 0 Do J = J + 1 Me.group = I DoCmd.GoToRecord , , acNext Loop Until J = X Loop Until I >= Me.txtClassCnt Me.Requery End If Err: Me.Undo Exit Sub توزيع.rar تجياتي

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

السلام عليكم مشاركة مع استاذي العزيز أبو عبدالله الحلوانى ملاحظة : الحل مبني حسب توجيهات استاذ أبو عبدالله الحلوانى RootSumf.rar

Try this File Jack_Numeration.xlsm

تفضل هذه المعادلة لعد أحرف الخلية =LEN(A4) أما بالنسبة لتحديد كتابة 31 حرف أو أقل فقط بالخلية فهذا يتم من خلال DataValidation كما بالصورة وتم تنفيذ ذلك على الملف بالفعل دالة عدد الاحرف.xlsx

وعليكم السلام-تم عمل المطلوب وزيادة ... فقد تم تنسيق شكل الفاتورة وعمل قواءم منسدلة لأسماء الأصناف وأسماء العملاء حتى يتم الأختيار من بينهم وان لا يوجد مجال للخطأ عند الكتابة -بارك الله فيك وأتمنى ان ينال إعجابك فاتورة_3.xlsm

عند تنفيذ الماكرو وجدت أنه يقوم بحذف تنسيق المراجع، من تغميق لعناوين المراجع أو الكلمات الموجود أسفلها خط هذا للعلم لطفاً

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

السلام عليكم ورحمة الله وبركاته ألف شكر لك على المشاركة المميزة أخي الحبيب أبو عاصم، وبعد: 1- هل لك أن تضع لنا ملف Word نطبق عليه الماكرو؟ 2- ماذا لو كان في الفهرس (أحمد بن محمد أبو القاسم القرطبي) أو (عبد الله بن أم مكتوم)؟ 3-من وجهة نظري الحل الأسلم يكون كالتالي: في إدخال الحقول أضف حقلين هكذا: { XE ابن عباس - عباس - \f person } بعد أن تنتهي من إضافة الحقول بهذا الشكل، تقوم بإدراج الفهرس، ثم تحول النص إلى جدول، ومن بند (فصل النص عند) تكتب (-)، سيصنع لك جدولاً قريباً من هذا الشكل: ابن عباس - عباس - رقم الصفحة الآن تقوم من فرز بترتيب الجدول حسب العمود الثاني، بعد ذلك تقوم بحذف العمود الثاني، وبذلك تنجح الطريقة دون ثغرات ومشاكل.

جرب المرفق لعله يفي بالغرض المصنف1( (1).xlsm

تم إتاحة نسخة بلغة html & javascript في هذه الصفحة https://www.mr-mas.com/p/tafqeet.html وتم تحديث الروابط في المشاركة الأولى ولا ينقصني سوى دعاؤكم

وعليكم السلام ورحمة الله وبركاته أخي العزيز مصطفى الخدمة موجودة ضمن إضافة البيان البحثية كما هو موضح في الصورة التالية: أيضاً يمكنك ذلك من خلال الكود التالي: في مربع البحث عن نكتب: ( ){1;}\((^2)\) وفي مربع استبدال بـ نكتب: (\2) مع تحديد خيار باستخدام أحرف البدل، كما في الصورة التالية:

بعد إذن أستاذنا الفاضل علي لإثراء الموضوع يمكن استعمال دالة vlookup شاهد الملف المرفق New Microsoft Excel Worksheet0.xlsx

استاتذتي وأخواني الكرام السلام عليكم ورحمة الله وبركاته منذ فترة طلب مني ألاخ / أبوادم علي البريد فـورم لنموذج فاتورة مبيعات باللغة الانجليزية مع الطباعة وبعد ان صممت النموذج أحببت ان اشارككم فيه عسي ان يكون فيه النفع وان يكون عام ليستفيد منه الباحث عن شيء شبيه النموذج مفتوح(( يمكن تطويعه لاي عمل اخر )) تنويه (( العلامة التجارية "الشعار"" والاسماء بالنموذج من محض الخيال وليس لها علاقة باي علامة تجارية حالية وذلك حفاظا علي الحقوق ولا تعتبر نوع من انواع الدعاية لاي جهة )) أحببت ان انوه فقط ربما تصادف اسم شركة قائمة. ( نموذج الفورم ) ------------------------- ----------------------------- والله ولي التوفيق نموذج فاتورة.rar

اهلا بك اخى الكريم فى المنتدى-بالتأكيد بعد اذن استاذنا الكبير ضاحى الغريب وذلك كما بالصورة

الظاهر هكذا !! بس لوسمحتي تأخذين صورة للشاشة وارسليها ، يمكن اعدادات تنسيق التاريخ عندك نظام امريكي ، يعني الشهر / اليوم / السنة ، والمشكلة هاي ما تبين إلا في التواريخ الاكبر من 12 !! ولكن ومثل ما تفضلتي ، غيري تنسيق التاريخ في جهازك واخبريني التجربة. ولكن ، رجاء تجربي هذا المرفق اولا وقبل تغيير اي شئ جعفر 566.1.Employees.mdb.zip