الـعيدروس

اذا اردت تكون البيانات الاوليه هيا التي تظهر في البداية لابد من عكس الاتجاه كما السابق من اليسار الى اليمين غيرتها في هذا المرفق لانه الحل الوحيد حالياً تم إضافة حذف جميع حركة الاسم من ورقة المتابعات مع الحذف السجل الاساسي وهيا بفورم الاستاذ العلامه عبدالله باقشير " زر حذف السجل الحالي " اضن انه اسرع بهذا المرفق التجربه خير برهان حسب الاليه الموجوده في ملفك بالامكان ان تضيف بدون زر تلقائي بمعنى : تضغط على الدائرة ثم تبحث عن الاسم المراد اضافة متابعه له ثم تدرج بياناتك كامله ثم تضغط زر مختصر مثلاً "F6" بدلا من الضغط على زر اضافة المتابعه ؟ Profser_3.rar

شاهد تجربتي بالمرفق شرح.rar

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

السلام عليكم بعد اذن الاستاذ عبدالله الحلقة التكراريه بتكون كالتالي Sub kh_Copy2() '***** أسماء الملفات ***** Ar_A "a1,a2,a3,a4,a5,a6" End Sub Public Function Ar_A(Par As Variant) As String Dim mPath$, oldName$, newName$ Dim i, A mPath = ThisWorkbook.Path & "\" A = Split(Par, ",") For i = 0 To UBound(A) oldName = mPath & "TEST" & "\" & A(i) & ".xls" newName = mPath & "mmm" & "\" & A(i) & ".xls" FileCopy oldName, newName Next i End Function

جرب هذه الطريقة ادخل مسار الصورة بالكود كما بالشرح ' إسم الصورة وإمتدادها Private Const Nm As String = "ddd.jpg" Public Sub Ali_Pr() Dim Pth As String ' هكذا مسار الصورة 'Pth = C:\Users\Public\Pictures\ddd.jpg ' مسار الصورة الحالي بنفس فولدر ملف الاكسل Pth = ThisWorkbook.Path & Application.PathSeparator & "\" & Nm ActiveSheet.PageSetup.CenterHeaderPicture.Filename = Pth With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "&G" .RightHeader = "" .LeftFooter = "" .RightFooter = "" If .Orientation = xlPortrait Then .HeaderMargin = Application.InchesToPoints(3) ElseIf .Orientation = xlLandscape Then .HeaderMargin = Application.InchesToPoints(3.5) End If End With End Sub

الاخ الحبيب ابو ندى مالاوفيس الذي تستخدمه ؟

ممكن ان شاء الله

السلام عليكم جرب هكذا Public Sub Ali_T() Const S As String = "لا اله إلا الله محمد رسول الله" ActiveSheet.Shapes.AddTextEffect(PresetTextEffect:=2, _ Text:=S, FontName:="Arial Black", FontSize:=36, FontBold:=False, FontItalic:=False, Left:=50, Top:=150).Select With Selection.ShapeRange .ScaleHeight 1.23, False .ScaleWidth 1.6, False .Fill.Visible = True .Fill.Solid .Fill.ForeColor.SchemeColor = 22 .Fill.Transparency = 0.5 .Line.Weight = 1# .Line.DashStyle = 1 .Line.Style = 1 .Line.Transparency = 0# .Line.Visible = True .Line.ForeColor.SchemeColor = 22 .Line.BackColor.RGB = RGB(255, 255, 255) .Height = 80 .Width = 400 End With End Sub

شاهد التعديل ان شاء الله يزبط معك Nm_Adrs_Ali_4.rar

السلام عليكم بعد اذن الاستاذ الحبيب جمال عبدالسميع جرب هذا الكود امل ان يفي بالغرض Public Sub Ali_Frmt() Dim Asm As String Dim Sht As Worksheet Dim Rng As Range, rn As Range Ne: Asm = InputBox("إدخل الكلمة المراد تنسيقها", "منتدى أوفسينا") If Asm = vbNullString Or Asm = Cancel Then Exit Sub Set Sht = ActiveSheet With Sht Col = Split(.UsedRange.Address, "$")(3) Rw = Split(.UsedRange.Address, "$")(4) Set Rng = .Range(.Cells(1, 1), .Cells(Rw, Col)) For Each rn In Rng If rn Like CStr(Asm) Then With rn .Interior.Color = RGB(242, 242, 242) .Borders.Color = RGB(255, 0, 0) .Borders.Weight = xlThick .Font.Bold = True End With Cn = Cn + 1 End If Next MsgBox "تم تنسيق الكلمات " & " وعدد الكمات : " & Cn, vbInformation, "" Cn = 0 If MsgBox("هل تريد تنسيق كلمات اخرى ؟", vbYesNo, "") = vbYes Then GoTo Ne End With End Sub

تم تعديل عنوان الموضوع يرجاء قراءة قواعد المشاركة قواعد المشاركة فى الموقع اضغط هنـــــــــامن فضلك لقراءة القواعد كاملة و بصفة خاصة نؤكدعلى ما يلي 1- يمنع منعا باتا نشر أية مواد تخالف حقوق الملكية الفكرية و يرجى الابلاغ عن المشاركات المخالفة من خلال زر تقرير اسفل المشاركة 2-يجب استخدام خاصيةالبحث قبل طرح السؤال توفيرا للوقت و الجهد. 3-ضرورة كتابة عنوان واضح للموضوع يدل على محتواه ويعطي وصفاً مختصرا للسؤال. 4-ممنوع منعا باتاً كتابة عناوين سينمائية مثل عاجل ، نداء الي فلان ، الي الخبراء ، طلب مساعدة ، أريد حلا..... 5-يمكن استعجال الرد باستخدام تعبير -للرفع- و غير مسموح بالالحاح او اللوم فجميع الاعضاء يشاركون تطوعا طبقا لسعة وقتهم. ومخالفة ذلك تعرض الموضوع للحذف

شرح طريقة التفعيل تفضل المرفق تفعيل.rar

تم تعديل عنوان الموضوع

الاخ الاستاذ شوقي ربيع عمل متقن وجميل وشرح كافي وافي لايتقنها إلا خبير متمكن تقبل مروري

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

هكذا Set Rng = Range("A1,B1,C1,D1,F1,C:C,D:D") ' إذا عمود تكتب A:A إذا خلية تكتب A1 وهذا الكود Dim Rng As Range Private Sub Worksheet_SelectionChange(ByVal Tr As Excel.Range) Set Rng = Range("A1,B1,C:C,D:D") If Not Intersect(Tr, Rng) Is Nothing Then Tr.Offset(0, 1).Select Set Rng = Nothing End If End Sub

السلام عليكم الصق الكود التالي في حدث الورقة Private Const Rng As String = "$E$4,$E$7,$E$10,$E$13,$E$16,$E$19" Private Sub CommandButton1_Click() Dim Og As Object, i With Feuil1 On Error Resume Next For Each Og In .OLEObjects With Og If Not .Name Like "CommandButton" Then Range(Split(Rng, ",")(i)).Cells.Value = .Object.Text: i = i + 1 End If End With Next On Error GoTo 0 End With End Sub Private Sub CommandButton2_Click() Range(Rng).ClearContents End Sub

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

السلام عليكم الاخ الحبيب office 2003 جرب المرفق لا أدري إن كان بيأدي الغرض التجربه خير برهان Nm_Adrs_Ali_3.rar

بعد اذن الاستاذ حماده حسب فهمي لطلبك تريد حماية عمود بالكامل او خلية معينه الحماية عبارة عن : عدم الوقوف على الخليه او العمود ولكن تستطيع تغير حجم العمود او الصف للخلايا المحميه جرب المرفق حاول توقف المؤشر على الخلايا الملونه حماية عمود او خلية.rar

السلام عليكم حل اخر الى حل الاخ والاستاذ ضاحي الغريب بعد كتابة القيمة تضغط انتر جمغ تلقائي في النموذج_A.rar

شاهد المرفق عند اختيار اضافة متابعة واذا الاسم ليس لديه ملاحظات إنقر مرتين على مربع الملاحظات Profser_2.rar

السلام عليكم تم إن شاء الله وإضافات بسيطه إكتشفها بنفسك أرجو التجربه إن وجدت أي أخطاء أو ملاحظات تحياتي Profser_1.rar

عمود امراض اخرى لااره في شيت المتابعه ؟ هل يعتبر مستثنى فيها

لم يرحلها شيء لإن العمود الأول فارغ ؟ والكود بيأخذ اخر صف به بيانات من العمود الأول جرب التعديل التالي Public S As String Public Sub Ali_Rn() Dim W As Workbook, Wr As Workbook Dim Sh As Worksheet Dim iC, Sn$ Dim Shet As Worksheet Dim Path$, My_F$, A_Num, i%, Lc&, L_A&, C Dim Rng As Range Dim A_Lst As Range SPd False Ali_Clr Sn = "المبيعات اليومية بالتفصيل" On Error Resume Next Set Wr = ThisWorkbook Path = ThisWorkbook.Path & Application.PathSeparator My_F = Dir(Path & "*.xlsx") Do While My_F <> "" If Not My_F = Wr.Name Then Workbooks.Open Filename:=Path & "\" & My_F Set W = Workbooks(My_F) For Each Sh In W.Worksheets With Sh SPd False Set Rng = .Range(.Cells(2, 1), .Cells(500, 35)) With Rng S = Replace(W.Name, ".xlsx", "") Set A_Lst = .Cells(2, .Columns.Count).End(xlToLeft) A_Num = A_Lst.Column End With If Sh.Name = Sn Then iC = 2 Else iC = 1 L_A = .Cells(.Rows.Count, iC).End(xlUp).Row Set Shet = Wr.Worksheets(.Name) With Wr.Worksheets(.Name) Lc = .Cells(.Rows.Count, iC).End(xlUp).Offset(1, 0).Row For C = 1 To A_Num For i = 2 To L_A .Range("A" & Lc - 1).Cells(i, C).Value = Sh.Cells(i, C).Value .Range("A" & Lc - 1).Cells(i, A_Num + 1).Value = S Next i Next End With End With A_Num = 0: R_Num = 0 Next W.Close 0 SPd True End If My_F = Dir Loop SPd True End Sub Private Function SPd(Bn As Boolean) With Application .Calculation = IIf(Bn, -4105, -4135) .EnableEvents = Bn .ScreenUpdating = Bn .DisplayAlerts = Bn End With End Function Private Sub Ali_Clr() Dim Dh As Worksheet For Each Dh In ThisWorkbook.Worksheets Dh.UsedRange.Cells.ClearContents Next End Sub ولا عليك نحنو بالخدمه لاتتردد بأي سؤال