رجب جاويش

أخى الفاضل / عبد الله يرجى ارفاق ملف يوضح ما تريد حتى يمكن للإخوة الزملاء العمل عليه

بارك الله فيك أخى الحبيب ياسر خليل

شكرا جزيلا أخى الحبيب ياسر خليل وجزاك الله كل خير

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

أخى الفاضل / خالد الرشيدى عندك حق يظهر إن الزهايمر اشتغل تانى هذا السطر لم يعد له أهمية فى الكود وفعلا نسيت حذفه بعد الانتهاء من الشكل النهائى للكود ربنا يستر على الذاكره جزاك الله كل خير ودا الشكل النهائى للكود بعد حذف السطر Sub ragab() Dim x As Integer Dim T As Variant Dim S_name As Range '============================================================= For Each T In Array("عام", "خاص", "مغلق", "مفتوح") On Error Resume Next With Sheets(T) Set S_name = .Columns(2).Find(What:=[d5], LookAt:=xlWhole) x = Application.WorksheetFunction.Match(T, [c8:c11], 0) + 7 .Cells(S_name.Row, 3) = Cells(x, 4) End With Next End Sub

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

جزاك الله خيرا أخى محمود الحمد لله أن تم المطلوب

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

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

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

السلام عليكم تفضل أخى محمود Sub ragab() Dim x As Integer Dim T As Variant Dim Rng As Range Dim S_name As Range '============================================================= For Each T In Array("عام", "خاص", "مغلق", "مفتوح") On Error Resume Next With Sheets(T) Set Rng = .Range("B6:B" & Cells(Rows.Count, "B").End(xlUp).Row) Set S_name = .Columns(2).Find(What:=[d5], LookAt:=xlWhole) x = Application.WorksheetFunction.Match(T, [c8:c11], 0) + 7 .Cells(S_name.Row, 3) = Cells(x, 4) End With Next End Sub بيانات1.rar

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

طيب ممكن بقى نتكلم فى الشبكة والمهر ولاوازم الفرح ولا هتعدوها على الضيق ولا ايه

أنا شخصيا موافق على الجوازة دى وندبح الاتنين فى ليلة الدخلة هههههههههههه

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

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

أخى الفاضل / أحمد جزاك الله كل خير أخى الحبيب / ياسر دى أقل واجب لما تقدمه من خدمات جليلة للجميع فى المنتدى على فكرة أخى الحبيب هذا المتغير ii هوا اللى أصر يكون موجود أثناء تقديم الهدية لكم لانه كان موجود أثناء تجارب أخرى لاضافات أخرى كنت أنوى اضافتها للكود ولما الاضافات لم تكتمل مرضيش يتحذف وأصر يحضر ويقدم الهدية معايا وبصراحة مرضيتش أكسفه هههههههههههههههه

تكملة لموضوع جعل النص بشكل رأسى الذى بدأه أخى الحبيب / ياسر خليل قررت اضافة فكره أخرى بالاضافة الى جعل النص بشكل رأسى وهذه الفكرة إهداء إلى أخى الحبيب ياسر خليل Option Explicit Private Sub CommandButton1_Click() Dim T1 As String, TT1 As String Dim T2 As String, TT2 As String Dim N As Byte, w As Single, Temp Dim i As Integer, ii As Integer '================================== TT1 = "YASSER KHALIL" TT2 = "ياسر خليل" N = 0: i = 1: ii = 1 Do While N < Len(TT1) T1 = T1 & Mid(TT1, i, 1) & Chr(13) T2 = T2 & Mid(TT2, i, 1) & Chr(13) i = i + 1: ii = ii + 1 Label1.Caption = T1 Label3.Caption = T2 w = 0.2 Temp = Timer Do While Timer < Temp + w DoEvents Loop N = N + 1 Loop End Sub اهداء الى أخى الحبيب ياسر خليل.rar

ربنا يديم المعروف والمودة والروح الطيبة الموجودة بين جميع أعضاء هذا المنتدى العريق أجمل وأرق تحياتى للجميع

شكرا جزيلا أخى الفاضل أبو بسمله وجزاك الله خيرا على هذا الدعاء الطيب

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

السلام عليكم أخى الحبيب / ياسر خليل أخى الفاضل / كاسر الأمواج بالنسبة للكود الرائع الخاص بأخى الحبيب ياسر فيه نقطة واحدة وهى انه عند الاختيار من ComboBox2 يضع فى ComboBox3 كل الخلايا من العمود E التى تقابل الاختيار الموجود للـ ComboBox2 ( وليكن مستشفيات ) مثلا بغض النظر عن الاختيار الموجود فى ComboBox1 الخاص باسم المحافظة أى أنه يضع الاماكن المقابلة لكلمة مستشفى فى كل المحافظات وليست المحافظة المختارة فقط وذلك بسبب الكود cValues ولذلك عملت تعديل بسيط على الكود الرائع وسميته cValuesR لتدارك تلك النقطة الخاصة بـ ComboBox3 Sub cValuesR(Txt1 As String, Txt2 As String, Obj As Object, Col As Integer) Dim Dn As Range Dim Rng As Range Dim Dic As Object Obj.Clear With Sheets("Sheet1") Set Rng = .Range(.Cells(6, Col), .Cells(Rows.Count, Col).End(xlUp)) End With Set Dic = CreateObject("Scripting.Dictionary") Dic.CompareMode = 1 For Each Dn In Rng If Dn.Offset(, -1).Value = Txt1 And Dn.Offset(, -2).Value = Txt2 Then If Not Dic.exists(Dn.Value) Then Dic(Dn.Value) = Empty End If End If Next Dn Obj.List = Application.Transpose(Dic.keys) End Sub Dependent ComboBox On UserForm YasserKhalil.rar

أخى الفاضل أنس جزاك الله خيرا على هذه الكلمات الطيبة

بعد اذن أخى الحبيب المبدع ياسر خليل ولاثراء الموضوع هذا كود آخر Private Sub save_pro_Click() Dim LC As Integer, LR As Long, I As Integer LR = Worksheets("4").Cells(Rows.Count, 1).End(xlUp).Row For I = 1 To 18 If Me.Controls("CheckBox" & I).Value = True Then LC = Worksheets("5").Range("IV1").End(xlToLeft).Column + 1 Range(Cells(1, I + 1), Cells(LR, I + 1)).Copy Worksheets("5").Cells(1, LC) End If Next Unload Me End Sub

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