شوقي ربيع

انشاء زر في الصفحة من المطور واربطه بهذا الماكرو Sub sho() UserForm2.Show End Sub الكود السابق لستدهاء الفورم الثاني

السلام عليكم استبدل الاكوادورم لديك بهاته الاكواد Option Explicit Sub VisSh(shNm As String) Dim S As Worksheet Sheets(shNm).Visible = True For Each S In Worksheets If S.Name <> Sheets(shNm).Name Then Sheets(S.Name).Visible = xlSheetVeryHidden Next End Sub Private Sub CommandButton1_Click() VisSh ("Sheet1") Unload Me End Sub Private Sub CommandButton2_Click() VisSh ("Sheet2") Unload Me End Sub Private Sub CommandButton3_Click() VisSh ("Sheet3") Unload Me End Sub

لسلام عليكم استعمل هذا الكود Sub Actv() Dim sh As Worksheet: Set sh = Sheet1 Dim lr As Long: lr = sh.Cells(sh.Rows.Count, "M").End(xlUp).Row + 1 Me.TextBox5.Value = sh.Range("B" & lr).Value End Sub كل ما تحتاجه قم باستدعائه فقط مثلا عندما تريد ان تضهر النتيجة في بداية اقلاع الفورم اكتب العبارة call activ في حدث UserForm_Initialize

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

السلام عليكم Dim i As Integer For i = 1 To 6 Cells(i, 1).Value = 100 Next i حلقة دورانية عدد دوراتها ستة دورات بدايتها 1 نهايتها 6 المتغير i ياخذ قيمة الحلقة الدوارانة مثلا في الدورة الاولى يأخذ القيمة 1 والدورة الثانية يأخذ القيمة 2 .......الى غاية الدورة الاخيرة ليأخذ القيمة 6 cells(i,1) تعني الخلية التي تقع في العمود الاول والصف يكون بقيمة المتغير i مثلا في الدورة الاولى للحلقة التكرارية تكون cells(1,1) في هذا المثال تأخذ الخلية الاولى في العمود الاول القيمة 100 وهكذا الى نهاية الحلقة التكرارية Dim i As Integer, j As Integer For i = 1 To 6 For j = 1 To 2 Cells(i, j).Value = 100 Next j Next i حلقة تكرارية متداخلة هنا لدينا حلقة دورانية داخل حلقة اخرى الحلقة الرئيسة تنفذ الحلقة الفرعية التي في داخلها ستة مرات اما الحلقة الفرعية تنفذ الامر الذي بداخلها مرتين لكي تفهمها بشكل ابسط فل نستعرضها بالعرض البطيء نفرض اننا في الدورة الاولى للحلقة الرئيسسية اذا المتغير i الخاص بها يأخذ القيمة 1 عندما يصل التنفيذ للحلقة الفرعية (الحلقة الثانية) المتغير j الخاص بها يأخذ القيمة 1 لانه في الدورة الاولى للحلقة الثانية ملاحظة لاينتقل تنفيذ الكود الى الاكواد الاخرى الا بعد انتهاء دورات الحلقة او ان كان هناك امر للخروج من الحلقة exit for اذا اصبحت قيمة i = 1 / j =1 ومنه يصبح شكل الكود ceels(1,1) يعني اننا في الخلية الاولى للعمود الاول كما قلنا سابقا ان تنفيذ الكود لاينتقل الابعد انتهاء الحلقة التكرارية اذن ستكمل حلقتنا الفرعية دورتها الثانية ومنه المتغير j سيأخذ القيمة 2 لاكن المتغير i سيبقى على قيمته الاولى أي 1 لان الكود لم ينتهي من دورات الحلقة الثانية ولم ينتقل الى الدورة الثانية للحلقة الاولى ومنه الكود يصبح على الشكل cells(1,2) ومعناه الخلية الاولى في العمود الثاني وهكدا لبقية دورات الحلقتين عند انتهاء الكود يكون لدينا في الشيت من الخلية الاولى الى الخلية السادسة في العمود الاول تساوى 100 كذالك نفس الامر بنسبة للعمود الثاني Dim c As Integer, i As Integer, j As Integer For c = 1 To 3 For i = 1 To 6 For j = 1 To 2 Worksheets(c).Cells(i, j).Value = 100 Next j Next i Next c هاته ايضا حلقة تكرارية متشابكة او متداخلة ان صح التعبيري نفس الكلام السابق لاكن بدل من انه لدينا حلقتين الان لدينا ثلاث حلقات الحلقة الاولى تنفذ ما بداخلها ثلاث مرات والثانية ننفذ ما بداخلها ستة مرات والثالثة تنفذ ما بداخلها مرتين Dim i As Integer i = 1 Do While i < 6 Cells(i, 1).Value = 20 i = i + 1 Loop هي ايضا حلقة دورانية الاختلاف بينها وبين ماسبق من حلقات هو الاولى لديها بدايو ونهاية محدود ام الثانية (Do Loop) ليس لديها نهاية (لا نهائية) انما تتوقف عن الدوران بشرط في المثال اعلاه الحلقة تنفذ ستة دورات لان االشرط هو اذا كانت قيمة المتغير اصغر من الستتة واصل الدوران ان كان اكبر توقف عن الدوران هذا شرح للكود كلاميا ان صح التعبير ملاحظة المثال في الكود الاخير و في الكود الاول ليس بينهما أي فرق كلاهما يعطي نفس النتيجة الفرق الوحيد ان الاخيرة اسرع في التنفيذ من الاولى ارجو ان يكون الشرح حول الحلقات مفوه اوكافي وان ان كان هناك أي استفسارات فلا تتردد تحياتي للجميع

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

السلام عليكم الف مليون تريليون مبروك للاخت الفاضلة ام عبد الله الترقية المستحقة وهنيأ لنا [اول خبيرة معتمدة تحياتي

السلام عليكم فورم الدرجات1.rar

السلام عليكم هذا كود يعطي شيتات بعدد المجلدات الفرعية المحتواة مع الملف بأسمائها يعني كل شيت يحمل اسم مجلد مهما كان عدد المجلدات و يقوم بكتابة اسماء الملفات المحتواة في المجلدات الفرعية في رؤس الاعمدة في الشيت الذي يحمل اسم نفس الملف و يرحل العمود الاول لتلك الملفات في العمود الذي يحمل اسم الملف جربه لكي تفهمه اكثر Option Explicit Sub Test() Dim Url As String: Url = ThisWorkbook.Path Dim Scr: Set Scr = CreateObject("Scripting.FileSystemObject") Dim F: Set F = Scr.GetFolder(Url) Dim Fil Dim Cl As Integer: Cl = 2 For Each Fil In F.SubFolders If Cl - 1 <= Sheets.Count Then Sheets(Cl - 1).Activate If Sheets(Cl - 1).Name <> Fil.Name Then Sheets(Cl - 1).Name = Fil.Name Else Sheets.Add After:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = Fil.Name Sheets(Sheets.Count).Activate End If Call LoopFiles(Fil.Name) Cl = Cl + 1 Next Set Scr = Nothing Set F = Nothing End Sub Sub LoopFiles(Folder As String) Dim Url As String: Url = ThisWorkbook.Path & "\" & Folder & "\" Dim StrFile As String: StrFile = Dir(Url & "\*csv*") Dim Clm As Long: Clm = 1 Dim Rw As Long Dim A As String Application.ScreenUpdating = False Do While Len(StrFile) > 0 Rw = 2 Cells(1, Clm) = "Nom Files " & StrFile Columns(Clm).AutoFit Open Url & StrFile For Input As #1 While Not EOF(1) Line Input #1, A Cells(Rw, Clm) = A Rw = Rw + 1 Wend Close #1 Clm = Clm + 1 StrFile = Dir Loop Application.ScreenUpdating = True End Sub تحياتي

السلام عليكم افضل دائما التعامل بالاكود بدل من الملفات وذالك لكي يتعلم السائل الى اقصى حد فمثلا ان كان لا يعرف تركيب الاكود في هذه الحالة يجبر على تعلم تركيبها وفي حالتك هته مثلا لو ركزة قليل فقط كنت ستكتشف بان عبارة end sub ناقصة وهي العبارة التي ينتهي او يقفل بيها أي كود على العموم اليك الملف مطبق عليه الكود ترقية المستخدم_4.rar

هذا لأنك مكرر اسم الكود addition_1 اكثر من مرة غيره فقط

السلام عليكم صراحتا لم افهم السؤال او الطلب جيدا لاكن صممت لك فورم ديناميكي حيث تكون اليبل او التكسات لكل ضرف مهما كان عددها ديناميكيا وزر للتعديل او الاضافة معا ارجو ان يلبي طلبك رصد الدرجات.rar

لسلام عليكم الكود السابق يعمل الذي تريده كان به خطاء بسيط تم تعديله جرب الكور واعلمني

السلام عليكم انا لم استطع تحميل الملف بسبب مشكل في النت عندي لاكن حسب مافهمت من طلبك وفي حالت ما اذا كان الاعمدة التي يطبق عليها الكود في الشيتات المذكورة اعلها متشابهة فان الكود يكون كالاتي Option Explicit Sub addition_1() Dim shN As String Dim r As Integer, i As Integer Dim lr As Long Dim y, y1 For i = 1 To Worksheets.Count shN =Sheets(i).Name If shN = "الادارية" Or _ shN = "الاتصالات" Or _ shN = "الغاز" Or _ shN = "المعمل" Or _ shN = "الطبية" Or _ shN = "الهندسية" Or _ shN = "الامن الصتاعى" Or _ shN = "المهمات" Or _ shN = "الانتاج" Or _ shN = "المعالجة" Or _ shN = "الصيانة" Then lr = Cells(Rows.Count, 7).End(xlUp).Row For r = 8 To lr y = Application.WorksheetFunction.IsNumber(Cells(7, 7)) y1 = Application.WorksheetFunction.IsNumber(Cells(21, 7)) If y And y1 And Cells(lr, 7) > 0 _ And Cells(lr, 21) > 0 Then Cells(lr, 7) = Cells(lr, 7) + 1: Cells(lr, 21) = Cells(lr, 21) + 1 End If Next End If Next

السلام عليكم الشكر موصول للاخوين طلعت محمد حسن و الاستاد رجب جاويش لاثراء الموضوع اكثر هذا كود ايضا يفي بالغرض Private Sub TextBox1_Change() Dim Lr As Long Dim i As Double, Mh As Double On Error Resume Next i = Me.TextBox1 Application.ScreenUpdating = False With Sheet1 Lr = .Cells(.Rows.Count, "D").End(xlUp).Row Mh = WorksheetFunction.Match(i, .Range("D4:D" & Lr), 0) + 3 End With Me.TextBox2 = Sheet1.Range("E" & Mh) Application.ScreenUpdating = True End Sub

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

السلام عليكم حاول ان تحفظ الملف بصيغة xlsm فالكود ليس له أي علاقة بالحفظ وارجو ان تعطيني الخطاء او الرسالة التي تضهر لك عند الحفظ

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

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

السلام عليكم احيانا الشخص منا يظن انه يملك الكم الكافي والازم فيما يخص برمجة الاكسل لاكن حين يقابل او يرى بعضا من ابداعات مبدعي الاكسل يعلم ان ماتعلمه هو سوى القليل وان برمجة vba بحر واسع وعميق تفضل اخي الكريم هذا الكود الرائع وجدته في احد المواقع الاجنبية هذا الكود يرسل البريد من الاكسل مباشرة الى البريد المرسل اليه لاكن تحتاج حساب في gmail وايضا يعتمد على اضافة Microsoft CDO for Windows 2000 لكي تضيفها شاهد هذه الصورة Sub SentMail() Dim Mail As New Message Dim Config As Configuration Set Config = Mail.Configuration Config(cdoSendUsingMethod) = cdoSendUsingPort Config(cdoSMTPServer) = "smtp.gmail.com" Config(cdoSMTPServerPort) = 25 Config(cdoSMTPAuthenticate) = cdoBasic Config(cdoSMTPUseSSL) = True Config(cdoSendUserName) = "بريدك الاكلتروفي GMAIL" Config(cdoSendPassword) = "الباسوورد" Config.Fields.Update Mail.To = "البريد المرسل ايه" Mail.from = Config(cdoSendUserName) Mail.Subject = "Email Subject" Mail.HTMLBody = "<b>Email body</b>" ' هذا هو الجزء الذي يرسل في هته الحال سيتم ارسال صورة من الجهاز الى بريد ما Mail.AddAttachment "C:\Users\Admin\Pictures\QQ.jpg" On Error Resume Next Mail.Send If Err.Number <> 0 Then MsgBox Err.Description, vbCritical, "There was an error" Exit Sub End If MsgBox "Your email hes sent!", vbInformation, "Sent" End Sub ان اعطاك خطاء قم باستبدال قيم البورت من 25 الى 465 المهم هذا بداية خيط لتعامل مع البريد الالكتروني من دون الاتولوك يبقى عليك معرفة كيفية استعمالها الانسب ارجو ان تستفيدو من هذا الكود الرائع من وجهة نضري منقـــــــــــــول

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

السلام عليكم استادنا القدير عبد الله باقشير اعمالك دائما لا غبار عليها و تنم عن الابداع المنقطع النظير فهنيا لنا بأستاد عظيم مثلك عندي ملا حظة صغبرة فقط وارجو ان لا تعتبرها تطاولا فنحن مجرد تلاميذ عندك استادي العزيز هي ان تكون سرعة تحرك البار متطابقة مع سرعة البحث ففي الملف الذي ادرجته مثلا الوقت المستغرق عند البحث عن رقم 1 اكثر من البحث عن رقم 2 لاكن سرعة البار هي نفسها في هذه الحالة ولما يكون عندنا قاعدة بيانات كبيرة الكود راح يزيد من بطاء البحث شخصيا استعمل كود بسيط لتحقيق هذا الغرض ويتماشا مع الحلاقات التكرارية كما هو الحال مع الكود الخاص بك If i Mod Lr / 100 = 0 Then PrgS = PrgS + 1 Image_barre1.Width = PrgS * 1.5 Label_barre1.Caption = PrgS & "%" DoEvents End If وقد ركبته على الملف الخاص بك كما هو في المرفق ارجو ان تعطينا رئيك فيه وان امكن تدمجه مع الكود الخاص بك واكرر اعتذاري كما ارجو ان تتقبل هته الملاحظة فليس لي غرض سوى تحريك واثراء الموضوع بالنقد او الاراء البنائة تقبل مني تحياتي وتقديري بار تحديث البيانات.rar

السلام عليكم Sub test() Dim Wsh As Worksheet, Wsh2 As Worksheet Dim Lrw As Long, Lr As Long Dim i As Integer, ii As Integer, iii As Integer Set Wsh2 = ThisWorkbook.Sheets("شاشة 3003") For i = 1 To Worksheets.Count If Worksheets(i).Name <> Wsh2.Name Then Set Wsh = Worksheets(i) Else GoTo 1 Lrw = Wsh.Cells(Wsh.Rows.Count, "P").End(xlUp).Row For ii = 11 To Lrw If Wsh.Range("T" & ii) <> "" Then Lr = Wsh2.Cells(Wsh2.Rows.Count, "C").End(xlUp).Row + 1 Wsh2.Range("A" & Lr) = Wsh.Range("T" & ii) Wsh2.Range("B" & Lr) = Wsh.Range("R" & ii) Wsh2.Range("F" & Lr) = Wsh.Range("F" & ii) Wsh2.Range("C" & Lr) = Wsh.Range("P" & ii) For iii = 1 To 5 If Wsh.Range("T" & ii + iii) = "" Then Wsh2.Range("C" & Lr + iii) = Wsh.Range("P" & ii + iii) Else GoTo 2 Next iii End If 2 Next ii 1 Next i End Sub Rabie Chaouki.rar

السلام عليكم لا اضن ان هذا الموقع المناسب لطلبك لاكن لابأس البرنامج الوحيد الذي يمكنه تنفيذ طلبك و يدعم العربية هو برنامج Readiris Corporate فيديو يشرح البرنامج http://www.youtube.com/watch?v=HbNNQNBmX7Y

السلام عليكم تما هو ذاك لاضافة ورقة اخرى وهدا كود اخر يعمل على جميع اوراق الملف وينقلها الى الاوراق المقابلة لها في الملف الجديد اذا اردت تحديد الاوراق التي سترحل كل ما عليك ضبط طول الحلقة التكرارية Sub Test() Dim Wkb1 As Workbook, Wkb2 As Workbook Dim wsh As Worksheet Dim i As Byte Set Wkb1 = ActiveWorkbook Workbooks.Add Set Wkb2 = ActiveWorkbook For i = 1 To Wkb1.Worksheets.Count Set wsh = Wkb1.Worksheets(i) Wkb2.Worksheets(i).Range(wsh.Range("A3:A15").Address).Value = wsh.Range("A3:A15").Value Next End Sub