husain alhammadi

السلام عليكم و رحمة الله و بركاتة جزاك الله خير الجزاء على التنبية و الصحيح هو sheet 4 form1.Hide Sheet4.Range("R4").Value = Application.WorksheetFunction.VLookup(rngUser.Offset(0, -1).Value, Sheet1.Range("d2:d100"), 1, False) Sheet4.Range("E4").Value = Date Sheet4.Range("I4").Value = Application.WorksheetFunction.Text(Sheet7.Range("I4").Value, "dddd") Sheet4.Range("M4").Value = Time form2.Show End If End Sub

السلام عليكم و رحمة الله و بركاتة اخواني هل يوجد خطا Private Sub CommandButton3_Click() Dim strUsername As String Dim strPassword As String Dim iRow As Integer strUsername = Me.TextBox1.Value strPassword = Me.TextBox2.Value On Error GoTo 1 iRow = Application.WorksheetFunction.Match(strUsername, Worksheets("صلاحيات").Range("d:d"), 0) 1 If Err.Number <> 0 Then MsgBox "تاكد من اسم المستخدم و كلمة المرور": Exit Sub If Worksheets("صلاحيات").Cells(iRow, 2).Value = strPassword Then MsgBox "تم تسجيل الدخول بنجاح!" Unload Me UserForm1.Show Else MsgBox "تاكد من اسم المستخدم و كلمة المرور" Me.TextBox1.Value = "" Me.TextBox2.Value = "" Me.TextBox1.SetFocus MsgBox ("أهلا وسهلا بك في برنامج "), vbOKOnly form1.Hide Sheet7.Range("R4").Value = Application.WorksheetFunction.VLookup(rngUser.Offset(0, -1).Value, Sheet1.Range("d2:d100"), 1, False) Sheet7.Range("E4").Value = Date Sheet7.Range("I4").Value = Application.WorksheetFunction.Text(Sheet7.Range("I4").Value, "dddd") Sheet7.Range("M4").Value = Time form2.Show End If End Sub فى الكود ان كان نعم ارجوا تصحيحها دخول.xlsm

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

البرنامج يختلف عن الاول

السلام عليكم و رحمة الله و بركاتة لكل مهنة أدواتها التي تساعد صاحب المهنة على أداء عمله بالشكل المطلوب وكل ما كانت هذه الأدوات حديثة ، كانت نتيجة العمل أفضل و أسرع وأكثر جودة وكفاءة. كذلك المبرمج المبتدئ، يحتاج إلى مجموعة من البرامج الأدوات التي تساعده على إنجاز العمل المطلوب بالشكل المناسب ، وتعبر شاشة الدخول هي أدوات المبرمج التي يستخدمها على حسب الحاجة المطلوبة والهدف المطلوب في كل مهمة ليتم إنجازها.و المطلوب اخواني تعديل البرنامج في عدة مراحل نبدء قمت بإرفاق ملف برنامج شاشة الدخول مع صلاحيات من إعدادي وهو بسيط وقمت بتحميله لسببين : الأول : أن يستفيد منه باقي الأعضاء . الثاني : توجد به عدة مشكلات أود من أحد الخبراء مساعدتي فيه . المطلوب : 1) : تعديل اكواد الدخول للبرنامج من صفحة الصلاحيات و يسجل عملية الدخول و الخروج في صفحة تقرير الدخول و على ان يظهر اسم المستخدم في الصفحة الرئيسية R4 2): اضافة كود في الصفحة الرئيسية تغيير كلمة المرور البرنامج للجميع و يمكن اضافة اي برنامج عليه بعد الانتهاء من جميع المراحل و يمكنكم التعديل عليها و اعادة نشره ليستفيد الجميع منه و جزاكم الله خير الجزاء و جعله الله في ميزان حسناتكم دخول.xlsm

السلام عليكم و رحمة الله و بركاتة تم استخدام معادلة الاستاذ أ / محمد صالح احتساب الساعات التي قضاها بين تاريخ الخروج وتاريخ الوصول.xlsx

للرفع

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

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

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

ساعة.xlsmتم حل الموضوع و البرنامج 100%

السلام عليكم و رحمة الله و بركاتة يسعدني في هذا الموقع تقديم الزمن الصحيح لجميع الصلوات طوال اليوم وذلك لجميع المدن في الدول العربية ، وهي مفيدة جداً لمن يقطنون في مناطق بعيدة عن المساجد ولا يستطيع معرفة اوقات الاذان لأي فرض طوال اليوم. للعلم بان الاكواد تم عملها بواسطه الاستاذ الكبير @ياسر خليل أبو البراء فجزاه الله خير الجزاء على المجهود و جعله الله في ميزان حسناتهم و المطلوب لاكمال الرنامج اولا : اضافة التاريخ الميلادي Label3 بحيث يتغير كل 50 ثانية ثانيا : اضافة وقت المتبقى للاذان فى Label30 ثالثا : تغيير مواقيت الصلاة من 24 ساعة الى 12 ساعة مواقيت الصلاة.xlsb

السلام عليكم و رحمة الله و بركاتة ارجوا منكم تصحيح الكود و الخاص D5 حيث يظهر ص و م بدلا من AM و PM و البرنامج يعمل بشكل ممتاز و مسموح للجميع اخذ نسخة منه و تطويره و هو مفتوح و لا يوجد به رقم سري و شكرا لكم ساعة.xlsm

السلام عليكم و رحمة الله و بركاتة ارجوا مساعدتي في كود خاص بالبرنامج المرفق بداية الادخال D18 و D20 يتم تجزئة الاسم اى حروف و يتم توزيعها فى E18 الى O19 و E20 الى O20 على يتم اخذ الحروف و الارقام من نفس الشيت وكذلك مطلوب كود M23 على ان يرتبط L23 و معدلة هي =L23-12-12-12-12-12-12-12- حتى يصل النتيجة الى رقم 12 او اقل منه و جزاكم الله خير اعرف برجك.zip

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

السلام عليكم و رحمة الله و بركاتة ارجوا مساعدتي في كود خاص بالبرنامج المرفق و الخاص بالترجمة اللغات بداية الادخال B2 و يتم نقل الكلمة الى C4 و بموجبه يتم البحث في جميع الصفحات من A3 الى A10000 و يتم نقل النتيجة B3 الى B10000في صفحة الرئيسية من C5 الى C13 حسب اللغة وشكرا لكم ترجمة.xlsx

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

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

جزاك الله خير

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

للرفع

للرفع

تم استخدام الكود Sub ترحيل_الفواتير() If Range("b6").Value = False Then MsgBox "من فضلك ادخل جميع البيانات " Else Dim lastrow As Integer Reply = MsgBox("هل رقم الفاتورة: " & Range("B6").Value & Chr(10) & " مسجل مسبقاً", vbYesNo) 'هنا هل تريد طبع النسخ ام لا If Reply <> 6 Then Exit Sub lastrow = [a9].End(xlUp).Row Range("a9:a24").Copy Sheets("تقريرالصرف").Range("a" & Sheets("تقريرالصرف").[a1048576].End(xlUp).Row + 1) Range("b6").Copy Sheets("تقريرالصرف").Range("b" & Sheets("تقريرالصرف").[b1048576].End(xlUp).Row + 1) Range("f6").Copy Sheets("تقريرالصرف").Range("c" & Sheets("تقريرالصرف").[c1048576].End(xlUp).Row + 1) Range("b9:b24").Copy Sheets("تقريرالصرف").Range("d" & Sheets("تقريرالصرف").[d1048576].End(xlUp).Row + 1) Range("c9:c24").Copy Sheets("تقريرالصرف").Range("e" & Sheets("تقريرالصرف").[e1048576].End(xlUp).Row + 1) Range("d9:d24").Copy Sheets("تقريرالصرف").Range("f" & Sheets("تقريرالصرف").[f1048576].End(xlUp).Row + 1) Range("e9:e24").Copy Sheets("تقريرالصرف").Range("g" & Sheets("تقريرالصرف").[g1048576].End(xlUp).Row + 1) Range("f9:f24").Copy Sheets("تقريرالصرف").Range("h" & Sheets("تقريرالصرف").[h1048576].End(xlUp).Row + 1) Range("g9:g24").Copy Sheets("تقريرالصرف").Range("i" & Sheets("تقريرالصرف").[i1048576].End(xlUp).Row + 1) Range("a28").Copy Sheets("تقريرالصرف").Range("j" & Sheets("تقريرالصرف").[j1048576].End(xlUp).Row + 1) Range("a29").Copy Sheets("تقريرالصرف").Range("k" & Sheets("تقريرالصرف").[k1048576].End(xlUp).Row + 1) Range("a30").Copy Sheets("تقريرالصرف").Range("l" & Sheets("تقريرالصرف").[l1048576].End(xlUp).Row + 1) Range("c28").Copy Sheets("تقريرالصرف").Range("m" & Sheets("تقريرالصرف").[m1048576].End(xlUp).Row + 1) Range("c29").Copy Sheets("تقريرالصرف").Range("n" & Sheets("تقريرالصرف").[n1048576].End(xlUp).Row + 1) Range("c30").Copy Sheets("تقريرالصرف").Range("o" & Sheets("تقريرالصرف").[o1048576].End(xlUp).Row + 1) Range("e28").Copy Sheets("تقريرالصرف").Range("p" & Sheets("تقريرالصرف").[p1048576].End(xlUp).Row + 1) Range("e29").Copy Sheets("تقريرالصرف").Range("q" & Sheets("تقريرالصرف").[q1048576].End(xlUp).Row + 1) Range("f30").Copy Sheets("تقريرالصرف").Range("r" & Sheets("تقريرالصرف").[r1048576].End(xlUp).Row + 1) x = Range("b6").Value MsgBox "تم ترحيل البيانات بنجاح الى صفحة تقريرالصرف:" & x End If End Sub ولكن الكود خاص بالرقم التسلسلي و رقم الصنف و اسم الصنف و الوحدة و السعر و الكمية و السعر الاجمالى لا يتم تفعيلة Range("a9:a24").Copy Sheets("تقريرالصرف").Range("a" & Sheets("تقريرالصرف").[a1048576].End(xlUp).Row + 1) Range("b6").Copy Sheets("تقريرالصرف").Range("b" & Sheets("تقريرالصرف").[b1048576].End(xlUp).Row + 1) Range("f6").Copy Sheets("تقريرالصرف").Range("c" & Sheets("تقريرالصرف").[c1048576].End(xlUp).Row + 1) Range("b9:b24").Copy Sheets("تقريرالصرف").Range("d" & Sheets("تقريرالصرف").[d1048576].End(xlUp).Row + 1) Range("c9:c24").Copy Sheets("تقريرالصرف").Range("e" & Sheets("تقريرالصرف").[e1048576].End(xlUp).Row + 1) Range("d9:d24").Copy Sheets("تقريرالصرف").Range("f" & Sheets("تقريرالصرف").[f1048576].End(xlUp).Row + 1) Range("e9:e24").Copy Sheets("تقريرالصرف").Range("g" & Sheets("تقريرالصرف").[g1048576].End(xlUp).Row + 1) Range("f9:f24").Copy Sheets("تقريرالصرف").Range("h" & Sheets("تقريرالصرف").[h1048576].End(xlUp).Row + 1) Range("g9:g24").Copy Sheets("تقريرالصرف").Range("i" & Sheets("تقريرالصرف").[i1048576].End(xlUp).Row + 1) اخواني بغيت الحل

السلام و رحمة الله و بركاتة تم تعديل الملف و المطلوب هو تفعيل الترحيل من الصرف الى تقريرالصرف و استدعاء الفاتورة اخواني الاعضاء اسمحوا لي حاولت كثيرا" و لم انجح ارجوا مساعدتي في ذلك يجب عليك بعد ذلك وضع الأكواد بهذه الطريقة فى المشاركة بالمكان المخصص لها Sub طباعة() Sheet13.Range("A1:G35").PrintPreview End Sub Private Sub CommandButton1_Click() Dim ws As Worksheet, sh As Worksheet, LR As Long, m As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("الصرف") Set sh = ThisWorkbook.Worksheets("تقريرالصرف") LR = Application.Max(9, ws.Range("B9").End(xlDown).Row) If LR < 9 Then Exit Sub m = sh.Cells(Rows.Count, 1).End(xlUp)(2).Row sh.Range("A" & m).Resize(LR - 8).Value = ws.Range("A9:G24" & LR).Value sh.Range("B" & m).Resize(LR - 8).Value = ws.Range("B6").Value sh.Range("C" & m).Resize(LR - 8).Value = ws.Range("F6").Value sh.Range("D" & m).Resize(LR - 8, 6).Value = ws.Range("B9:G24" & LR).Value ws.Range("A9:G24").SpecialCells(xlCellTypeConstants).Cells.ClearContents Application.ScreenUpdating = True End Sub Sub newInvoice() xx = Sheets("الصرف").[A999999].End(xlUp) If IsNumeric(xx) Then n = xx + 1 Else n = 200001 [F6] = n End Sub Sub مسح_الفاتورة() Reply = MsgBox(" هام جداً " & Chr(10) & "هل تريد مسح البيانات ", vbYesNo) 'ActiveSheet.Unprotect (123) If Reply <> 6 Then Exit Sub Range("b6") = "" Range("g6") = "" Range("b9:b24") = "" Range("c9:c24") = "" Range("d9:d24") = "" Range("e9:e24") = "" Range("f9:f24") = "" Range("g9:g24") = "" Range("c25") = "" Range("g25") = "" Range("a28:a30") = "" Range("c28:c30") = "" Range("e28:e30") = "" 'ActiveSheet.Protect (123) End Sub Sub استدعاء_فاتورة_من_الفواتير() Dim Filename As String Filename = Range("B6").Value Workbooks.Open ("e:\الفواتير\" & Filename & ".xlsm") End Sub Sub حفظ_في_الاستعلام() Dim Extension$, savePathName As String If Cells(1, 6) = "" Or Cells(1, 2) = "" Then MsgBox "من فضلك ادخل نوع الفاتورة ", vbOKOnly, " تنبيه": Exit Sub Ayadah = Cells(1, 6) Extension = Cells(1, 2) & ".xls" savePathName = "d:\المطلوب\قيد التنفيز\الشغل الخلصان\" & Ayadah & "\" On Error Resume Next Application.DisplayAlerts = False GetAttr (savePathName) Select Case Err.Number Case Is = 0 Application.DisplayAlerts = False ThisWorkbook.SaveCopyAs savePathName & Extension MsgBox "الاسم موجود مسبقاً وتم إضافة العمل فيه", vbOKOnly, "تنبيه" Application.DisplayAlerts = True Case Else MkDir savePathName ThisWorkbook.SaveCopyAs savePathName & Extension MsgBox "تم انشاء فلدر وحفظ العمل فيه", vbOKOnly, "تنبيه" End Select On Error GoTo 0 End Sub Sub حفظ_الفاتورة() 'Private Sub CommandButton2_Click() Reply = MsgBox(" هل تريد" & Chr(10) & " حفظ الفاتورة ", vbYesNo) 'هنا هل تريد طبع النسخ ام لا If Reply <> 6 Then Exit Sub If Cells(1, 7) = "" Or Cells(1, 2) = "" Then MsgBox " من فضلك ادخل اسم العميل- ونوع الفاتورة ", vbOKOnly, " تنبيه": Exit Sub Ayadah = Cells(1, 7) Extension = Cells(1, 2) & ".xls" If Cells(1, 2).Value = "" Then ' اسم المجلد ' MsgBox "يجب عليك إتباع ما يلي " & vbNewLine & vbNewLine & " كتابة اسم الملف " & vbNewLine & " كتابة اسم المجلد " & vbNewLine & vbNewLine & "ثم الضغط على حفظ", vbInformation + vbMsgBoxRight, "خطأ" Exit Sub Else Dim MyPathDirectory, MyNime On Error GoTo MSG MyPathDirectory = Cells(1, 10).Text & ":\" & Cells(1, 2).Text 'هذ الستر لو تحدد اي مجلد للحفظ علية MyPathDirectory = Cells.Text & "d:\OneDrive\المطلوب\" & Cells(1, 2).Text & Nombre & " " & Format(Now, " dd-mm-yyyy") & "" ' MyPathDirectory = Cells.Text & "h:\حساب يوم بيوم\" & Cells(1, 2).Text & Nombre & " " & Format(Now, " dd-mm-yyyy") & "" 'هنا تحديد مكان الحفظ' MyNime = "\" & Cells(1, 2).Text & ".xls" '°°° If Dir(MyPathDirectory & MyNime) > "" Then MsgBox "هذا الملف موجود مسبقا يجب اختيار مسار آخر", vbCritical, "Faute" MkDir (MyPathDirectory) ActiveWorkbook.SaveCopyAs MyPathDirectory & MyNime x = Range("b1").Value MsgBox "تم حفظ فاتورة:" & x Application.ScreenUpdating = False With Sheets("Sheet13") 'هنا حدد الشيت المراد طباعتة' Dim ss As String ss = "‎Send To OneNote 2016 على ‎nul:" With .UsedRange For i = 1 To .Rows.Count If .Cells(i, 1).Value = "" Then .Cells(i, 1).EntireRow.Hidden = True '-c معتمد علي العمود 'هذا الستر الذي يمنع الفراغ End If Next i End With .PrintOut Rows.Hidden = False End With MSG: Reply = MsgBox(" هام جداً " & Chr(10) & "هل تريد مسح البيانات ", vbYesNo) If Reply <> 6 Then Exit Sub Range("b6") = "" Range("g6") = "" Range("b9:b24") = "" Range("c9:c24") = "" Range("d9:d24") = "" Range("e9:e24") = "" Range("f9:f24") = "" Range("g9:g24") = "" Range("c25") = "" Range("g25") = "" Range("a28:a30") = "" Range("c28:c30") = "" Range("e28:e30") = "" 'ActiveSheet.Unprotect (123) Range("b6").Value = Range("b6").Value + 1 'ActiveSheet.Protect (123) End If End Sub Sub احضار_الاصناف() Reply = MsgBox(" هام جداً " & Chr(10) & "هل تريد بيانات الصنف ", vbYesNo) If Reply <> 6 Then Exit Sub Sheets("Sheet16").Activate 'هنا تحديد اسم الشيت الذي به البينات' Dim LR As Integer LR = [b1].End(xlUp).Row Range("b9:e9" & LR).Copy Sheets(1).Activate Range("C" & [b9].End(xlUp).Row + 7).PasteSpecial xlPasteValues Sheets(1).Activate 'MsgBox "تم احضار بيانات الصنف " End Sub Sub ترحيل_الفواتير() If Range("b6").Value = False Then MsgBox "من فضلك ادخل جميع البيانات " Else Dim lastrow As Integer Reply = MsgBox("هل رقم الفاتورة: " & Range("B6").Value & Chr(10) & " مسجل مسبقاً", vbYesNo) 'هنا هل تريد طبع النسخ ام لا If Reply <> 6 Then Exit Sub lastrow = [a4].End(xlUp).Row Range("a1:m2" & lastrow).Copy Sheets("تقريرالصرف").Range("a" & Sheets("تقريرالصرف").[a1048576].End(xlUp).Row + 2) Range("i2").Value = Range("i2").Value + 1 x = Range("b6").Value MsgBox "تم ترحيل البيانات بنجاح الى صفحة:" & x Reply = MsgBox(" هام جداً " & Chr(10) & "هل تريد مسح البيانات ", vbYesNo) If Reply <> 6 Then Exit Sub Range("b6") = "" Range("g6") = "" Range("b9:b24") = "" Range("c9:c24") = "" Range("d9:d24") = "" Range("e9:e24") = "" Range("f9:f24") = "" Range("g9:g24") = "" Range("c25") = "" Range("g25") = "" Range("a28:a30") = "" Range("c28:c30") = "" Range("e28:e30") = "" End If 'Range("a4:h4" & lastrow).ClearContents End Sub الفاتورة 1.xlsm

السلام عليكم و رحمة الله و بركاتة ارفق لكم ملف اكسل خاص بالمستودع C8 D8 E8 F8 I11 من شيت بيانات الاصناف B11 بداية السنة المالية و هو ثابت لجميع الاصناف B12 الى E12 من شيت تقريرالوارد B12 و F13 G13 H13 من شيت تقريرالوارد اخواني الاعضاء ارجو منكم تصحيح الكود بطاقة الصنف بالملف المرفق و جزاكم الله خير Copy of Book2.zip