Alaaq3

أنا اعتذر منك استاذنا العزيز . شكراً لجهودك المحترمة

أُستاذنا العزيز عبد الفتاح... اجدد شكري وتقديري لحظرتك وأُقدر حرصك على المواضيع التي تُطرح في المنتدى. استاذنا لم اطلب مراجعة جميع أسطر المحرر بل اعتمدت على شكل اليوزر فورم من خلال الملف المرفق والصورة لذلك من البديهي إن خاصية وعمل أداة الـ checkbox هي اتخاذ إجراء وإلغاءه (check & Uncheck) 

أما عن المحاولات فإني حاولت كثيراً ولم افلح لذلك التجأت للاساتذة في هذا المنتدى. تحياتي

الاخ العزيز عبد الفتاح.. شكراً لمتابعتك مواضيع المنتدى بشكل دقيق ومجدي وقد اجبت عن موضوعي مشكوراً، كذلك انا رأيت توقيعك بعدم التعديل وتفهمت الموضوع ولم اطلب تعديلاً بناءً على توقيعك الموقر وقلت(اردتُ ان اطلب) وبالفعل لم اطلب هذا في الواقع .

اما بخصوص تنويهك بإضافة كل تفاصيل الموضوع من البداية بدلاً من طلبات التعديل في كل مرة؟! 

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

تحياتي 🌹

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

الغاية من الموضوع هو نسخ اعمدة محددة، وكذلك منعاً لبعثرة الشيت الاصلي عندما اجري عليه بعض العمليات مثل الفلترة والحذف وغيرها 

السلام عليكم ورحمة الله وبركاته " اريد عندما اضغط على اي خيار من  checkboxs يقوم بنسخ محتويات العمود الذي اخترته من الشيت الاول الى الشيت الثاني وهكذا بالتسلسل

انتبه من فضلك .. مشاركة مكررة فقد تــــم بالفعل حذف المشاركة الأخرى

check column.xlsm

احسنت اخي الكريم : جزاك الله الف خير

السلام عليكم ورحمة الله : احصائية.xlsmاريد احضائية بيانات تظهر على الفورم معرفة عدد الذكور ..عدد الاناث.. عدد الاذكور البالغين الموظفين .. عدد الذكور البالغين العاطلين ... عدد الذكور الاحداث الموظفين ... الخ 

احصائية.xlsm

شكرا لك اخي العزيز . جزاك الله الف خير

اخي الكريم ارفقت ملف ياريت تطلع عليه وتقوم بتعديله

لدي مشكلة في هذا الكود عندما اقوم باختيار الكل فأن البيانات تختفي

Private Sub ComboBox1_Change()
ActiveSheet.Range("B2").CurrentRegion.AutoFilter Field:=2, Criteria1:=ComboBox1.Value
End Sub
Private Sub UserForm_Initialize()
ComboBox1.List = Array("الكل", "ذكر", "انثى")
End Sub

الجنس.xlsm

احسنت اخي العزيز . جزاك الله الف خير

كود حذف تنسيق الصفوف الاخيرة الفارغة

ClearFormats 
Sheets("sheet1").UsedRange.SpecialCells(xlCellTypeBlanks).ClearFormats 

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

ممكن كود يقوم بتحديد الخلايا التي تحتوي على نص في الشيت 

تم حل الموضوع

الاساتذة الكرام : هذا الكود يقوم بفلترة البيانات من على (listbox) فقط في وضع الاختيار المفردة Single وعندما اقوم بتغيير خصائص الـ listbox الى خيارات متعددة فأن الفلترة تتوقف . ارجو المساعد.

المرفقات:

الفورم vba

صورة الفورم

فلترة متعددة.xlsm

السلام عليكم . الاساتذة الاعزاء شاهدت فيديو لشخص يقوم بفتح كاميرا ويب من خلال اليوزرفورم عن طريق اداة موجودة في التول بوكس اسمها (VedioCap) 

وسأقوم بارفاق الملف الموجود في الشرح مع صورة توضيحية للاداة (VedioCap) . كيف لي ان اقوم بعمل ذلك ؟

Capture Photo in Excel.xlsm

احسنتم جميعاً. جزاكم الله الف خير

السلام عليكم .كيفية التحكم في الشيت وتعديله مع ان الفورم يكون ظاهراً 

شكراً اخي العزيز : الكود رائع واستفدت منه كثيرا.  ولكن انا اريد ان اكتب صيغة الكسور ( النصف او الثلث او الربع) .  مثلاً هذا الكود الي بالاسفل يقوم بانقاص 45 يوم من كل 6 اشهر (اي الربع) . ما اريده هو كتابة (ComboBox3 * -1.5) مثلا

TextBox3.Value = Format(DateAdd("d", (ComboBox3 * -45), TextBox2), "YYYY/MM/DD")

توضيح اكثر : مثلا اريد ان اقوم بإنقاص الربع او النصف او الثلث من الـ 7 اشهر 

كيف اعبر عن انقاص الكسور من تاريخ معين (مثال: بدل ان اكتب (- ٤٥ يوم) اكتب بدل عنها "شهر ونصف" ) او اكتب انقاص ثلث التاريخ او ربع التاريخ 

DateAdd("d", (Val(TextBox4) * -45)

احسنتم كثيرا كيلا الطريقتان نجحتا

جزاك الله الف خير أستاذ محمد صالح .الكود يعمل باحسن ما يكون . ولكن هل بالامكان اضافة شرطاً ثالث ؟!

بمعنى ( اذا كانت السنوات اكبر اويساوي (1) و الشهور اكبر او يساوي (6) يتم انقاص (3)شهر من كل سنة  و (45) يوم من كل 6 اشهر فما فوق  . كذلك (الشرط الثالث) اذا كانت الشهور ((أكبر)) من 6 يتم انقاص (45) يوم  حتى وان كانت السنوات قيمتها 0 

---------

بصراحة حاولت كثيرا والنتيجة تكون غير صحيحة الكود قام بانقاص 45 يوم لمرتين اي 3 اشهر !!!

تحياتي لك استاذ محمد وشكراً من القلب لك

السلام عليكم الاستاذة الكرام : هذا الكود يقوم بانقاص 3 اشهر من كل سنة . اريد  اضافة كود يقوم بانقاص (شهر ونص) من كل 6 اشهر 

TextBox3 = DateAdd("m", (Val(TextBox4) * -3), TextBox2)

الان اريد انقاص شهر ونصف من كل 6 اشهر فما فوق من خانة TextBox5 الخاصة بالشهور بشرط ان تكون خانة TextBox4 الخاصة بالسنوات قيمتها اكثر من 0

توضيح/// . يتم انقاص (الشهر والنصف) من خانة الشهور مشروطة بشرطين: الاول ان تكون قيمتها اكبر او تساوي 6 . والشرط الثاني ان تكون في خانة السنوات قيمة اكثر او يساوي سنة 

حساب وجمع التواريخ (1).xlsm

السلام عليكم ورحمة الله : الاساتذة الكرام ارجو المساعدة في موضوع حفظ مكان الصور . هذا الفورم المرفق يقوم بحفظ الصور بجانب ملف الاكسل . وانا اريد ان يحفظها في مكان اخر مثلا ( ملف الاكسل على سطح المكتب والصور في قرص /:E) 

بيان الموظفين.xlsm

Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub CommandButton2_Click()
image_path = Application.GetOpenFilename(FileFilter:="Picture Files (Fichiers image),*.gif;*.jpg;*.jpeg;*.bmp", Title:="اختار الصورة")
If image_path <> False Then
Me.Image1.Picture = LoadPicture(image_path)
Me.Image1.Visible = True
End If
End Sub

Private Sub CommandButton3_Click()
If TextBox2.Value = "" Then MsgBox "ادخل اسم الصورة اولا": Exit Sub
Var = TextBox2.Text

مكان حفظ الصور '

SavePicture Image1.Picture, ThisWorkbook.Path & "\" & Var & ".jpg"
MsgBox "تم حفظ الصورة بنجاح مع تحيات مجدى يونس", vbInformation
End Sub

Private Sub Image1_Click()

End Sub

Private Sub TextBox1_Change()
'=============================

Dim MYPATH
MYPATH = ThisWorkbook.Path & "\" & TextBox1.Text & ".JPG"
If Right(MYPATH, 1) <> "\" Then
On Error GoTo 1
Image1.Picture = LoadPicture(MYPATH)
Else
1:
'MsgBox "هذا الصورة غير موجودة", vbInformation, "خطأ"
'Image1.Picture = LoadPicture()
Image1.Picture = LoadPicture(ThisWorkbook.Path & "\M.JPG")
Exit Sub
End If
'==========================================

End Sub

Private Sub TextBox2_Change()

End Sub

Private Sub UserForm_Click()

End Sub

Private Sub Yh_ListFind_Click()
On Error Resume Next
Dim MYSH As Worksheet
Dim S_1 As String
S_1 = Yh_ListFind.List(Yh_ListFind.ListIndex, 6)
Set MYSH = Sheets("new")
With MYSH
    .Select
    .Range(S_1).Select
End With
TextBox1.Value = Range(S_1).Value
End Sub

Private Sub Yh_ListFind_DblClick(ByVal cancel As MSForms.ReturnBoolean)
On Error Resume Next
Dim MYSH As Worksheet
Dim S_1 As String
S_1 = Yh_ListFind.List(Yh_ListFind.ListIndex, 6)
Set MYSH = Sheets("new")
With MYSH
    .Select
    .Range(S_1).Select
End With
Me.Hide
End Sub

Private Sub Yh_TextFind_Change()
On Error Resume Next
Dim MYSH As Worksheet
Dim V As Integer, LastRow As Integer
Dim M As String
Dim A, F
Yh_ListFind.Clear
If Yh_TextFind.Text = "" Then GoTo 1
M = Yh_TextFind.Text
        Set MYSH = Sheets("new")
        With MYSH
            LastRow = .Cells(.Rows.Count, "d").End(xlUp).Row
            Set A = .Range("d13:d" & LastRow).Find(M)
            If Not A Is Nothing Then
                F = A.Address
                Do
                If Application.WorksheetFunction.Search(M, A, 1) = 1 Then
                    Yh_ListFind.AddItem A.Value
                    Yh_ListFind.List(V, 1) = A.Offset(0, 1).Value
                    Yh_ListFind.List(V, 2) = A.Offset(0, 2).Value
                    Yh_ListFind.List(V, 3) = A.Offset(0, 3).Value
                    Yh_ListFind.List(V, 4) = A.Offset(0, 4).Value
                    Yh_ListFind.List(V, 5) = A.Offset(0, 5).Value
                    Yh_ListFind.List(V, 6) = A.Address
                    V = V + 1
                 End If
                Set A = .Range("d13:d" & LastRow).FindNext(A)
                Loop While Not A Is Nothing And A.Address <> F
            End If
        End With

On Error GoTo 0
1 End Sub