نجوم المشاركات

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

أستاذي الفاضل ابراهيم أبو ليله لا شكر على واجب .. فأفضالك عل المنتدى بصفة عامّة وعلينا بصفة خاصّة .. لا تنتهي .. ولا تُحصى و لا تُعد جزاك الله خيرًا و زادك من علمه و فضله احتراماتي

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

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله مع التحديث الجديد .. للأسف لم أجد التوجيهات التي تم وضعها من قبل ، وهذه القواعد والأسس هامة جداً ليدرك الأعضاء كيفية التعامل مع المنتدى طبعاً الموضوع سيكون متجدد .. سيتم وضع القواعد مرة أخرى فالرجاء الرجاء أن تساعدوني في اتمام الأمر .. كل عضو يذكرني بتوجيه من هذه التوجيهات ليتم إرساء القواعد ، إذ أن نجاح أي مؤسسة يعتمد في المقام الأول على قواعد ومنهج ثابت للسير على دربه التوجيهات والقواعد التي يجب مراعاتها التوجيه الأول : قبل طرح موضوع جديد يتعلق بطلب محدد يرجى استخدام خاصية البحث أولاً ، فإذا لم يجد طارح الموضوع بغيته ، فعليه أن يقوم بطرح موضوع جديد ، وفي هذه الحالة على طارح الموضوع أن يعلم أن حسن السؤال شطر الإجابة ، فاللباقة واللياقة والكياسة من الصفات التي يجب أن يتحلى بها طالب العلم. التوجيه الثاني : عند طرح موضوع جديد ، يتم وضع عنوان مناسب للطلب بحيث يفهم الطلب قبل الإطلاع عليه ، وعلى طارح الموضوع أن يبتعد عن العناوين الغير مجدية مثل : ( طلب مساعدة - الرجاء المساعدة - ساعدوني من فضلكم - عاجل وهام - الحقوني - نداء للعباقرة - نداء للعمالقة - إلى آخر تلك العناوين ...) ، وأمر آخر ألا يكون العنوان على شكل سؤال أو طلب .. نبتعد عن كلمة "طلب" مثال تطبيقي : نفترض أنني أريد معادلة تجمع القيم في عمودين العنوان المناسب للطلب يكون بهذا الشكل : معادلة جمع القيم في عمودين والنتائج في عمود آخر التوجيه الثالث : أن يتم توضيح المطلوب بالموضوع بشكل يزال معه أي لبس ، وفي نفس الوقت يراعى الإجمال في الطلب ، فأقصر الخطوط هو الخط المستقيم ، بمعنى "لا إطالة مملة ولا اختصار مخل" ، أي لا يكون طرح الموضوع مختصر للغاية بل يجب أن يستوفي جميع العناصر المطلوبة ، ومن ضمنها أن يحدد طارح الموضوع هل الحل المطلوب بالمعادلات أم بالأكواد أم بكلاهما لتكون الأمور واضحة بالنسبة لمن يريد تقديم المساعدة ، وأن يقوم صاحب الموضوع بإرفاق ملف به بيانات وهمية لتوضيح طلبه وللوصول إلى حل سريع ودقيق ، وإذا صعب على طارح الموضوع شرح المطلوب يمكنه إرفاق بعض النتائج المتوقعة كي يسهل الوصول لحل. التوجيه الرابع : نلاحظ أن شكل المنتدى لا يعجب معظم الأعضاء ، فلما لا نغير بأيدينا الشكل العام للمشاركات ، فيفضل على سبيل المثال استخدام حجم خط كبير 22 على سبيل المثال وجعل الخط عريض Bold مما يجعل المشاركة واضحة ومقروءة بشكل جيد ، كما يمكن استخدام الألوان أي قم بتنسيق المشاركة بشكل جذاب يجعل القاريء لا ينفر منها. التوجيه الخامس : بعد الانتهاء من الموضوع والوصول لحل يرضي صاحب الموضوع ، يرجى أن يتم تحديد أفضل إجابة من خلال النقر على علامة الصح الموجودة بجانب كل مشاركة ، وأن يسجل صاحب الموضوع إعجابه من خلال النقر على "سجل اعجاب بهذا" كنوع من رد الجميل لمن قدم المساعدة ، ويمكن أيضاً أن يقوم بتقييم المشاركة تقييم إيجابي كنوع من التقدير ، وأن تشكر من قدم المساعدة فمن لم يشكر الناس لا يشكر الله. فيما يخص لو كان هناك أكثر من إجابة للموضوع ، يمكن لصاحب الموضوع عمل مشاركة جديدة يجمع فيها كل الحلول ويختار هذه المشاركة كأفضل إجابة التوجيه السادس : لا تكن لحوحاً ، يكفي أن أعضاء المنتدى يقدمون وقتهم و خبرتهم مقابل لا شيء وعندهم أعمال أخرى (مشاغلهم الخاصة) يقومون بها ، و إذا تأخر الرد ، فمن الممكن أن يكون أحد الأعضاء يقوم بمحاولة الإجابة ، وهذا يستغرق بعض الوقت خاصةً إذا كان الموضوع صعباً. التوجيه السابع : حمل الملف المرفق دون زركشات (ألوان و تنسيقات مختلفة) مما يزيد من حجم الملف و أحياناً تكون الألوان مقززة بشكل ينفر منها المساعد (خاصةً إذا كانت ألوان الخلايا غير متناسقة مع لون الخط) التوجيه الثامن : تأكد أن الملف المرفوع غير مصاب بفيروس و غير محمي بكلمة سر ، وإلا لن تجد المساعدة من قبل الأعضاء. التوجيه التاسع : متابعة صاحب الموضوع لموضوعه والتفاعل معه ، فلا يعقل أن يطرح أحدهم موضوع ولا يتابعه إلا بعد مرور وقت طويل ، فهذا يعد من اللامبالاة الغير مرغوب فيها ، والتي تنفر الجميع من العضو. التوجيه العاشر : عدم التسجيل في المنتدى بأكثر من حساب ، وأن يكون اسم الظهور باللغة العربية ومعبر عن الاسم الحقيقي أي (تعريب اسم العضو) ، فلا يجوز أن يكون اسم الظهور اسم واحد وفقط بل أن يكون ثنائي على الأقل أو أن يكون اسم ولقب ، ولذا يرجى عدم استخدام الأسماء المستعارة أو الأسماء باللغة الأجنبية ، فاللغة العربية هي هويتنا ولابد من الحافظ عليها. ** يتم تغيير اسم الظهور أو اسم المستخدم من خلال إعدادات الحساب ثم التبويب اسم المستخدم ، قم بتغيير الاسم ثم انقر كلمة حفظ التوجيه الحادي عشر : عدم طرح أكثر من موضوع لنفس الطلب من نفس العضو ، فهذا يعد مخالفة صريحة ، وليعلم العضو الذي يقوم بذلك أن تكرار الموضوع لن يجدي نفعاً في حالة عدم توضيحه للمطلوب. وفي حالة أن قام العضو بذلك عن طريق الخطأ يقوم العضو بالتنويه في الموضوع وطلب حذف الموضوع نظراً لتكراره. التوجيه الثاني عشر : على من يقدم المساعدة أن يكون مثالاً يحتذى به في العطاء والصبر والحلم وكرم الأخلاق وحسن الإجابة ، يجتذب بتلك الصفات عقول الآخرين وأفئدتهم التوجيه الثالث عشر : عند طرح موضوع يفضل أن يكون هناك طلب واحد فقط إذ أن الموضوع الذي تكثر فيه الطلبات ينفر الأعضاء الذين يريدون تقديم يد المساعدة ، وعلى رأي المثل (من يطارد عصفورين يفقدهما) فما بالك لو طاردت أكثر من طلبين أقصد أكثر من عصفورين ، يمكنك أن تتعامل بذكاء بأن تطرح الموضوع بطلب واحد حتى إذا تم على خير قم على الفور بطرح موضع جديد بطلب جديد وهكذا إلى أن يتم الأمر التوجيه الرابع عشر : يرجلا عدم إرسال رسائل خاصة للأعضاء لطلب المساعدة بشكل شخصي ، لأن هذا الأمر يضايق الكثير من الأعضاء ، وتأكد أن العضو إذا كان لديه معلومة أو يستطيع أن يفيد بشيء ووقته يسمح بذلك فلن يتأخر عنك ، يكفي أن تكتب كلمة "للرفع" في موضوعك ، ليشاهده أكبر عدد من الأعضاء. ** كيفية رفع الصور في المشاركات : ******************************* دمتم على طاعة الله

السلام عليكم الفكرة جميله وتنفع فى جدولة الأعمال او اعياد الميلاد لكن فيها خطأ برمجى صغير فى السطر expd = Worksheets("Notifications").Range("A2") المفروض انه يقرا من الخلية A1 فى الشيت Main expd = Worksheets("Main").Range("A1") وكمان تبقى افضل لو حدد ادنى للتاريخ انه ما يكونش اقل من تاريخ اليوم لانى لاحظت انه جايب لى تنبيهات من سنة فاتت بتغيير السطر التالى If (.Cells(irow, 7) - MyDate) <= expd Then الى If (.Cells(irow, 7) - MyDate) <= expd And (.Cells(irow, 7) - MyDate) > -1 Then تنبيهات 1.rar

جرب المرفق... لعل فيه المطلوب بن علية ترقيم حسب الشهر لمعيار معين.zip

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

الاخ العزيز ساشرح لك طريقة وان شاء الله تفيدك قم بعمل ملف جديد وضع فيه ملفك ثم قم بفتح درايف الـ C ثم اختر Programfiles ثم قم بفتح مجلد برنامج الـ WinRAR ثم انسخ منه الملف UnRAR زوضعه داخل المجلد الذى قمت بانشائه من قبل ووضعت فيه ملفك ثم قم بفتح المفكرة وانسخ بها الكود التالى ثم احفظه بداخل المجلد باسم Passwardcrcker.Bat ثم قم بالضغط على هذا الملف الذى قمت بانشاءه وقم بنسخ مسار ملف من داخل المجلد الذى انشاته ثم الصقه داخل الشاشة السوداء التى ستظهر معك بعد الضغط على الملف الذى به الكود واضغط انتر وانتظر حتى تظهر لك كلمة السر الخاصة بملفك مرفق الكود WinRAR Password _er.rar

استاذى الحبيب حضرتك تقصد الكتابه فى التكست بوكس فأذا كنت تقصد ذالك نعم فقط قم بنسخ الكود وضعه فى حدث Exit للتكست بوكس Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) 'انسخ الكود هنا End Sub أو حدث AfterUpdate للتكست بوكس Private Sub TextBox1_AfterUpdate() 'انسخ الكود هنا End Sub كلاهما يؤدى نفس الغرض وجرب بنفسك وستجد ما يسرك تقبل تحياتى

الاخ الكريم عبدالعزيز ما اروع ما قدمت جزاكم الله خيرا مرفق ملفى الذى تقدمت به من قبل ولكن بعد التعديل وتدراك الخطأ تقبلوا تحياتى Book1 - Copy.zip

السلام عليكم الاخوه الافاضل بصراحه التنوع الجميل ده اكبر دليل على ان عالم VBA اكبر مما نتخيل وزى ما بيقولو فى الامثال الى يعيش ياما يشوف فى انتظار المزيد من الحلول تقبلوا تحياتى

السلام عليكم لقد انتهيت من تصميم الفورم و الكود .. كتبت الكود و جربته على أوفيس 2007 ويندوز XP طبعا ينبغي تعديل ال API Declarations لكي يعمل الكود على الويندوز 64 بت ارجو أن يعجبكم العمل لقطة من اشاشة : ملف للتحميل : https://app.box.com/s/pn0ogngk3swhfbxbugk8f87ookrqb18b الكود: 1- كود في موديول الفورم: PaintingPuzzleGame Option Explicit Private Type POINTAPI X As Long y As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Type uPicDesc Size As Long Type As Long hPic As Long hPal As Long End Type Private Declare Function FindWindow Lib "User32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long Private Declare Function InvalidateRect Lib "User32.dll" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long Private Declare Function MessageBeep Lib "user32" (ByVal wType As Long) As Long Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Declare Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long Private Const PICTYPE_BITMAP = &H1 Private Const SRCCOPY = &HCC0020 Private Const SM_CXSCREEN = 0 Private Const SM_CYSCREEN = 1 Private Const SND_ASYNC As Long = &H1 Private Const SND_FILENAME As Long = &H20000 Private Const SND_LOOP As Long = &H8 Private Const SND_PURGE = &H40 'Module level variables Private oCol As Collection Private oPic As Object Private bScore As Boolean Private bExit As Boolean Private bAbort As Boolean Private InitialFormLeft As Single Private InitialFormTop As Single Private lFrmHwnd As Long Private lCounter As Long Private lTotalImageParts As Long Private lColumns As Long Private lRows As Long Private sLevel As String Private sUserName As String Private vFileName As Variant Private Sub UserForm_Initialize() sUserName = InputBox("Please, enter your name", "Player Name") If Len(sUserName) = 0 And StrPtr(sUserName) <> 0 Then MsgBox "You must enter a player name", vbInformation: End If StrPtr(sUserName) = 0 Then End End Sub Private Sub UserForm_Activate() StartUpPosition = 2 InitialFormLeft = Me.Left InitialFormTop = Me.Top Set oPic = frameSourcePic.Picture lFrmHwnd = FindWindow(vbNullString, Me.Caption) frameSourcePic.BorderStyle = fmBorderStyleSingle frameSourcePic.BorderColor = vbYellow With Me.ComboLevel .AddItem "Easy " & " (3x6 Parts)" .AddItem "low " & " (3x8 Parts)" .AddItem "Medium " & "(4x10 Parts)" .AddItem "High " & "(6x13 Parts)" .ListIndex = 0 End With lblTimer.Caption = "" CBtnAbort.Enabled = False Call EnableControls(True) End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If MsgBox("Are you sure you want to quit ?", vbQuestion + vbYesNo) = vbNo Then Cancel = 1 Exit Sub End If bExit = True End Sub '*************************************************************************************************** 'Event handlers of form's controls Private Sub ComboLevel_Change() Select Case True Case UCase(ComboLevel.Value) Like "EASY*" lRows = 3 lColumns = 6 Case UCase(ComboLevel.Value) Like "LOW*" lRows = 3 lColumns = 8 Case UCase(ComboLevel.Value) Like "MEDIUM*" lRows = 4 lColumns = 10 Case UCase(ComboLevel.Value) Like "HIGH*" lRows = 6 lColumns = 13 End Select sLevel = UCase(ComboLevel.Value) End Sub Private Sub CBtnAbort_Click() Call EnableControls(False) bAbort = True End Sub Private Sub CBtnClose_Click() Unload Me End Sub Private Sub CBtnNewPic_Click() On Error GoTo errHandler vFileName = Application.GetOpenFilename(FileFilter:="Picture Files (*.gif;*.jpg;*.jpeg;*.bmp),*.gif;*.jpg;*.jpeg;*.bmp", _ Title:="Select Picture") If vFileName <> False Then frameSourcePic.Picture = LoadPicture(vFileName) Call DeletePreviousImages End If Exit Sub errHandler: MsgBox Err.Description End Sub Private Sub CBtnStart_Click() Dim oImagePartCls As oImagePartCls Dim oTextBox As msforms.TextBox Dim tRect As RECT Dim tPt1 As POINTAPI, tPt2 As POINTAPI Dim BasePicframeHwnd As Long Dim lImgPartWidth As Long, lImgPartHeight As Long Dim lImgPartLeft As Long, lImgPartTop As Long Dim lColumn As Long, lRow As Long Dim lControlCounter As Long bScore = False bAbort = False Call EnableControls(False) BasePicframeHwnd = frameSourcePic.[_GethWnd] GetWindowRect BasePicframeHwnd, tRect tPt1.X = tRect.Left tPt1.y = tRect.Top tPt2.X = tRect.Right tPt2.y = tRect.Bottom If IsFormClipped(tPt1, tPt2) Then Me.Move InitialFormLeft, InitialFormTop GetWindowRect BasePicframeHwnd, tRect DoEvents End If Call DeletePreviousImages 'add the image parts controls Set oCol = New Collection For lColumn = 1 To lRows For lRow = 1 To lColumns lControlCounter = lControlCounter + 1 Set oImagePartCls = New oImagePartCls Set oImagePartCls.GetForm = Me Set oImagePartCls.PicturePart = Controls.Add("Forms.Image.1", "Image" & lControlCounter) With oImagePartCls.PicturePart .PictureSizeMode = fmPictureSizeModeStretch .BorderStyle = fmBorderStyleSingle .BorderColor = vbYellow .MousePointer = fmMousePointerSizeAll .Width = frameSourcePic.Width / lRows .Height = frameSourcePic.Height / lColumns .Left = frameSourcePic.Left + (((lRow - 1) * (frameSourcePic.Width + 20) / lRows)) .Top = 20 + (((lColumn - 1) * (frameSourcePic.Height + 20) / lColumns)) .ZOrder 0 .ControlTipText = "Drag the Picture down to its corresponding empty frame below" End With oCol.Add oImagePartCls Next Next 'add the textbox holder controls lControlCounter = 0 For lRow = 1 To lColumns For lColumn = 1 To lRows lControlCounter = lControlCounter + 1 Set oTextBox = Controls.Add("Forms.TextBox.1", "TextBox" & lControlCounter) With oTextBox .Enabled = False .BackStyle = fmBackStyleTransparent .BorderStyle = fmBorderStyleSingle .SpecialEffect = fmSpecialEffectEtched .Left = frameSourcePic.Left + frameSourcePic.Width + 80 + lColumn * frameSourcePic.Width / lRows .Top = frameSourcePic.Top + (lRow - 1) * frameSourcePic.Height / lColumns .Width = oImagePartCls.PicturePart.Width .Height = oImagePartCls.PicturePart.Height .ZOrder 1 End With Next Next 'randomly shuffle the image part controls lTotalImageParts = lColumns * lRows Me.Tag = lTotalImageParts ReDim iArray(1 To lTotalImageParts) As Integer ' Call ShufflePictureParts(lTotalImageParts, iArray) 'set the Pic property of each image part lControlCounter = 0 For lColumn = 1 To lColumns For lRow = 1 To lRows With tRect lImgPartWidth = (.Right - .Left) / lRows lImgPartHeight = (.Bottom - .Top) / lColumns lImgPartLeft = .Left + ((lRow - 1) * lImgPartWidth) lImgPartTop = .Top + ((lColumn - 1) * lImgPartHeight) End With lControlCounter = lControlCounter + 1 Controls("image" & iArray(lControlCounter)).Tag = Controls("TextBox" & lControlCounter).Name CropPic lImgPartWidth, lImgPartHeight, lImgPartLeft, lImgPartTop, Me.Controls("image" & iArray(lControlCounter)) InvalidateRect lFrmHwnd, 0, 0 Next Next frameSourcePic.BorderStyle = fmBorderStyleSingle frameSourcePic.BorderColor = vbYellow Call UpdateTimerLabel End Sub '************************************************************************************************* ' Private Supporting routines Private Sub UpdateTimerLabel() Dim ss As Long Dim mm As Long Dim hh As Long Dim sglTimer As Single Const WAV_FILE As String = "C:\WINDOWS\MEDIA\tada.WAV" sglTimer = Timer Do ss = Int(Timer - sglTimer) If ss = 60 Then mm = mm + 1: ss = 0: sglTimer = Timer If mm = 60 Then hh = hh + 1: mm = 0: sglTimer = Timer lblTimer.Caption = Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs" DoEvents Loop Until bExit Or bScore Or bAbort If bScore Then PlaySoundAPI WAV_FILE, ByVal 0&, SND_FILENAME Or SND_LOOP Or SND_ASYNC If MsgBox("Congratulations " & sUserName & " !!" & vbCrLf & vbCrLf & _ "You scored in : " & Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs" & vbCrLf & _ "Do you want to save this score to your scores history ?", vbQuestion + vbYesNo) = vbYes Then Call SaveTheScore(hh, mm, ss) End If PlaySoundAPI WAV_FILE, ByVal 0&, SND_FILENAME Or SND_PURGE End If lblTimer.Caption = "" Call EnableControls(True) Call DeletePreviousImages Set frameSourcePic.Picture = oPic End Sub Private Sub SaveTheScore(ByVal hh As Long, mm As Long, ByVal ss As Long) Dim bProtection As Boolean bProtection = ActiveSheet.ProtectContents If bProtection Then ActiveSheet.Unprotect End If With Cells(Cells.Rows.Count, 1).End(xlUp) .Offset(1, 0) = sUserName .Offset(1, 1) = Now .Offset(1, 2) = IIf(vFileName = Empty, "Default Picture", vFileName) .Offset(1, 3) = sLevel .Offset(1, 4) = Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs" End With If bProtection Then ActiveSheet.Protect End If ThisWorkbook.Save End Sub Private Sub CropPic(ByVal nWidth, ByVal nHeight, ByVal X, ByVal y, DestCtrl As Image) Dim hdc As Long Dim hDCMemory As Long Dim hBmp As Long Dim OldBMP As Long Dim IID_IDispatch As GUID Dim uPicinfo As uPicDesc Dim IPic As IPicture hdc = GetDC(0) hDCMemory = CreateCompatibleDC(hdc) hBmp = CreateCompatibleBitmap(hdc, nWidth, nHeight) OldBMP = SelectObject(hDCMemory, hBmp) Call BitBlt(hDCMemory, 0, 0, nWidth, nHeight, hdc, X, y, SRCCOPY) With IID_IDispatch .Data1 = &H20400 .Data4(0) = &HC0 .Data4(7) = &H46 End With With uPicinfo .Size = Len(uPicinfo) .Type = PICTYPE_BITMAP .hPic = hBmp .hPal = 0 End With OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic Set DestCtrl.Picture = IPic ReleaseDC 0, hdc DeleteObject OldBMP DeleteDC hDCMemory End Sub Private Sub ShufflePictureParts(ByVal NumOfPics, ByRef Arr() As Integer) Dim i As Integer, lRandomNumber As Integer, temp As Integer For i = 1 To NumOfPics Arr(i) = i Next i Randomize Timer For i = 1 To NumOfPics lRandomNumber = Int(Rnd * (UBound(Arr) - LBound(Arr) + 1) + LBound(Arr)) temp = Arr(i) Arr(i) = Arr(lRandomNumber) Arr(lRandomNumber) = temp Next i End Sub Private Sub DeletePreviousImages() Dim i As Long Dim oCtl As Control On Error Resume Next If Not oCol Is Nothing Then For i = 1 To oCol.Count Controls.Remove Controls("Image" & i).Name Next For Each oCtl In Me.Controls If TypeName(oCtl) = "TextBox" Then Controls.Remove oCtl.Name End If If TypeName(oCtl) = "Image" Then Controls.Remove oCtl.Name End If Next End If End Sub Private Function IsFormClipped(tLeftTop As POINTAPI, tRightBottom As POINTAPI) As Boolean IsFormClipped = _ tLeftTop.X <= 1 Or tLeftTop.y <= 1 Or tRightBottom.X >= GetSystemMetrics(SM_CXSCREEN) - 1 Or _ tRightBottom.y >= GetSystemMetrics(SM_CYSCREEN) - 1 End Function Private Sub EnableControls(ByVal Bool As Boolean) CBtnAbort.Enabled = Not Bool CBtnNewPic.Enabled = Bool CBtnStart.Enabled = Bool ComboLevel.Enabled = Bool End Sub '************************************************************************************************************* ' Public Methods Public Sub MsgbBeep() MessageBeep &H40& End Sub Public Sub FlashImagePart(ByVal Img As Image, ByVal ct As msforms.TextBox) Dim i As Long Dim t As Single For i = 0 To 1 Img.BorderStyle = fmBorderStyleSingle Img.BorderColor = vbRed t = Timer Do DoEvents Loop Until Timer - t >= 0.2 Img.BorderStyle = fmBorderStyleNone Next End Sub Public Sub CheckIfSuccess() Dim oCtrl As Control Dim lCounter As Long For Each oCtrl In Me.Controls If TypeName(oCtrl) = "Image" Then If InStr(1, oCtrl.Tag, "Success") Then lCounter = lCounter + 1 If lCounter = lTotalImageParts Then bScore = True End If End If End If Next End Sub 2- الكود في الكلاس موديول : oImagePartCls Option Explicit Public WithEvents PicturePart As msforms.Image Private initialY As Single, initialX As Single Private oUForm As Object Public Property Set GetForm(ByVal vNewValue As Object) Set oUForm = vNewValue End Property Private Sub PicturePart_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal y As Single) initialX = X: initialY = y PicturePart.ZOrder 0 End Sub Private Sub PicturePart_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal y As Single) Dim oCtrl As Control Static oPrevCtrl As Control If Button = 1 Then With PicturePart .Move .Left + (X - initialX), .Top + (y - initialY) For Each oCtrl In oUForm.Controls If TypeName(oCtrl) = "TextBox" Then If Not oPrevCtrl Is Nothing Then oPrevCtrl.Enabled = False oPrevCtrl.BackStyle = fmBackStyleTransparent oPrevCtrl.SpecialEffect = fmSpecialEffectEtched End If If .Left + .Width / 2 > oCtrl.Left And .Left + .Width / 2 < oCtrl.Left + oCtrl.Width _ And .Top + .Height / 2 > oCtrl.Top And .Top + .Height / 2 < oCtrl.Top + oCtrl.Height Then oCtrl.Enabled = True oCtrl.BackStyle = fmBackStyleOpaque oCtrl.SpecialEffect = 6 oCtrl.BackColor = vbWhite Set oPrevCtrl = oCtrl Exit For End If End If Next End With End If End Sub Private Sub PicturePart_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal y As Single) Dim oCtrl As Control For Each oCtrl In oUForm.Controls If TypeName(oCtrl) = "TextBox" Then With PicturePart If .Left + .Width / 2 > oCtrl.Left And .Left + .Width / 2 < oCtrl.Left + oCtrl.Width _ And .Top + .Height / 2 > oCtrl.Top And .Top + .Height / 2 < oCtrl.Top + oCtrl.Height Then .Move oCtrl.Left, oCtrl.Top PicturePart.BorderStyle = fmBorderStyleNone Call oUForm.FlashImagePart(PicturePart, oCtrl) If InStr(1, PicturePart.Tag, oCtrl.Name) Then PicturePart.Tag = PicturePart.Tag & "Success" Else If Right(PicturePart.Tag, 7) = "Success" Then PicturePart.Tag = Mid(PicturePart.Tag, 1, Len(PicturePart.Tag) - 7) End If End If Call oUForm.MsgbBeep Call oUForm.CheckIfSuccess Exit For End If End With End If Next End Sub

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

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

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

السلام عليكم ورحمة الله أخي الكريم، أعتقد أنه يجب وضع الكود المعني في موديول مستقل Standard Module وليس مثل ما فعلت بوضعه في All Open Workbooks ثم ربطه بـ زر Button في أي شيت من الشيتات... والله أعلى وأعلم أخوك بن علية

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

السلام عليكم الملف شغال بس انت عامله مختفى "hidden" الغى الاخفاء واعمل له حفظ وهو يشتغل تمام لما تفتحه تانى

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

أخي الحبيب وائل عوداً حميداً وبارك الله فيك على الموضوع ممكن تشرح الملف بمزيد من التفصيل إذا توفر لديك الوقت .. وجزاكم الله خير الجزاء

ا / بن علية الف شكر و لا اروع و اعمق مما كنت اتخيل بارك الله فيك الشكر ايضا موصول للاستاذ / ياسر للمتابعة و الاهتمام

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

أخي الكريم ابو جنى يرجى تغيير اسم الظهور للغة العربية كما يرجى الإطلاع على رابط التوجيهات في الموضوعات المثبتة بالمنتدى لمعرفة كيفية التعامل مع المنتدى بشكل أفضل جرب الكود التالي عله يفي بالغرض Sub PDF() Dim MyFile As String, lRow As Long Application.ScreenUpdating = False With Sheet4 .Visible = True MyFile = "D:\NEW\" & Sheets(2).Range("F3") & "-" & Sheets(2).Range("F2") & ".pdf" lRow = Sheets(4).Range("G" & Rows.Count).End(xlUp).Row + 1 .Range("A1:Z12").Value = Sheets(2).Range("A1:Z12").Value .Range("C14:U22").Value = Sheets(2).Range("AC1:AU9").Value .Range("A26:A177").Value = Sheets(1).Range("A3:A154").Value .Range("C26:C177").Value = Sheets(1).Range("B3:B154").Value .Range("E26:E177").Value = Sheets(1).Range("C3:C154").Value .Range("F26:F177").Value = Sheets(1).Range("D3:D154").Value .Range("G26:G177").Value = Sheets(1).Range("E3:E154").Value .Range("I26:I177").Value = Sheets(1).Range("H3:H154").Value .Range("J25:J177").Value = Sheets(1).Range("L2:L154").Value .Range("K25:K177").Value = Sheets(1).Range("M2:M154").Value .Range("L25:L177").Value = Sheets(1).Range("N2:N154").Value .Range("M25:M177").Value = Sheets(1).Range("O2:O154").Value .Range("N25:N177").Value = Sheets(1).Range("P2:P154").Value .Range("O25:O177").Value = Sheets(1).Range("Q2:Q154").Value .Range("P25:P26").Value = Sheets(1).Range("R2:R3").Value .Range("Q25:Q26").Value = Sheets(1).Range("S2:S3").Value .Range("F23").Value = Sheets(1).Range("F1").Value .ExportAsFixedFormat Type:=xlTypePDF, Filename:=MyFile .Visible = xlSheetHidden End With Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله وبركاته الدرس السادس 8-Loop الحلقات التكراريه وسوف نتناول فى هذه الدرس الاتى لماذا نستخدم الحلقات التكراريه انواع الحلقات التكراريه الخروج من الحلقه التكراريه كيفية استخدام اكثر من حلقه داخل الكود ......................................................................... لماذا نستخدم الحلقات التكراريه انا شخصيا بعتبر الحلقات التكراريه واحده من اهم المواضيع التى يجب معرفتها حينما يتم الدخول الى عالم vba يتم استخدام الحلقات التكراريه لتنفيذ اكثر من امر فى وقت واحد مما يوفر الوقت ولتوضيح ذلك راجع المثال الاتى نفترض اننا لدينا مجموعه من الارقام مثلا 7 ارقام (1-2-3-4-5-6-7) ونريد ادخال هذه الارقم فى السطر الثامن بداية من العمود الخامس اى العمود e فكيف سنقوم بعمل ذلك طبعا الى معندوش فكره عن كيفية استخدام الحلقات التكراريه هيستخدم الكود الاتى Sub enterdata() [e8] = "1" [f8] = "2" [g8] = "3" [h8] = "4" [i8] = "5" [j8] = "6" [k8] = "7" End Sub اى سيقوم بالاشاره الى كل خليه على حده واعطاء كل خليه قيمتها كما هو متضح من الصوره وبالتالى بعد كتابة هذه الكود وتخصيص زر لتنفيذه او بالوقوف داخل الكود بالماوس ثم الضغط على f5 سوف يتم ملئ الخلايا بالبيانات كما فى الصوره دعونا الان نتطرق الى كيفيه تنفيذ ذلك بالحلقات التكراريه انواع الحلقات التكراريه 1- FOR 2- WHILE 3- DO ................................................................................................................................................................................................................................................................ الحلقه الاولى for …next هذه الحلقه تبدأ بكلمة FOR وتنتهى بكلمة NEXT وفيما بين الكلميتن هو ما سوف يتم تنفيذه للتوضيح اكتر For بداية الحلقه = اسم الحلقه To طريقه تنفيذ الحلقه] نهايةالحلقه] [ماسيتم تنفيذه داخل الحلقه] [Exit For] الخروج من الحلقه Next استكمال الحلقه حت النهاية وهنا يجب ان نشير الى ان اى حلقه تكراريه لابد ان يكون لها اسم يعبر عنها وليكن مثلا H ثم يجب ان يكون لها بدايه ولها نهايه وليكن ستبدأ من 1 وتنتهى فى 10 ثم سيكون هناك ما ينفذ داخل الحلقه والمقصود بطريقة تنفيذ الحلقه اى هل سيتم تنفيذها خطوه بخطوه وهذا هو الشائع فى الاستخدام ام كل خطويتن ام كل ثلاث خطوات وهكذا ولتطبيق ذلك سنتعرف على كيفية استخدام الحلقه for فى ادخال البيانات فلو اننا نريد ادخال الارقام من 1 الى 4 فى السطر 26 بداية من العمود 8 كيف سنقوم بعمل ذلك 1-نعطى الحلقه اسم معين FOR H H 2-نحدد البدايه 8 ونحدد النهاية 11 FOR H =8 TO 11 لاحظ ان عدد الحلقات هنا 4 عباره عن 8و9و10و111 3-ماسيتم تنفيذه Cells(26, h) = h - 7 4-استكمال الحلقه NEXT وبالتالى سيكون شكل الكود كالاتى Sub enterdata_for() For h = 8 To 11 ' h----- متغير تم تعريه على انه يبدأ من 8 وينتهى عند 11 ' اى ان عدد حلقاته هى 4 عباره عن 8ثم9ثم10ثم11 Cells(26, h) = h - 7 ' هنا يتم تنفيذ الكود ' هنا نقول ان الخليه التى تقع فى السطر26 وفى العمود من8الى11 ' مطروحا منه 7 ارقام ليصبح قيمة المتغير تساوى1hتساوى قيمة المتغير ' Cells(26, H)--- الرقم26هنا يدل على رقم السطر الذى سينفذ فيه الكود ' Cells(26, H)--- عباره عن العمود الذى سينفذ فيه الكود وبذلك يتضحh ' hلنا ان الكود سوف ينفذ على الاعمده من 8الى11 لانها تساوى قيمة المتغير ' h-7 يبدأ من الرقم8وينتهى عند الرقم11 فحينما ينم طرحhبما ان المتغير ' الرقم7 من المتغير بذلك تصبح قيمة المتغير تبدأ من الرقم1وتنتهى عند الرقم4 'وبذلك يكون تنفيذ الكود كالاتى ' الخليه فى السطر26وفى العمود5تساوى الرقم1ثم ' الخليه فى السطر26وفى العمود6تساوى الرقم2ثم ' الخليه فى السطر26وفى العمود6تساوى الرقم3ثم ' وهكذا حت نصل الى اخر الحلقه التكراريه اى العمود11 Next ' hتكرار عمل الكود حتى نهاية المتغير ' next---- forاقفال الحلقه التكراريه End Sub ويكون ناتج الكود بهذا الشكل اما اذا اردنا تنفيذ الكود على الخلايا بشكل عمودى بدلا من الخلايا الافقيه بمعنى لو اننا اردنا مثلا تنفيذ نفس الكود على الخلايا من h23 الى h26 اى فى الخلايا h23 و h24 و h25 و h26 كيف سيكون شكل الكود الكود هيكون نفس الكود السابق ولكن ما سيختلف هو اننا سوف نعيد تغير قيمة المتغير h الخاص بالحلقه التكراريه ليصبح من 23 الى 26 ثم نقوم بتغير موضع المتغير h الخاص بالحلقه التكراريه من الصف الى العمود للتوضيح اكثر الفكره هكلها محصوره فى السطرين دول For h = 8 To 11 هنا طبعا قيمة المتغير h الخاص بالحلقه التكراريه من 8 الى 11 احنا عايزين نخليه يبقى من 23 الى 26 يبقى هيكون بالشكل ده For h = 23 To 26 وكمان فى السطر ده Cells(26, h) = h - 7 وطبعا احنا قولنا ان الجزئيه دى Cells(26 تعنى ان الكود سوف ينفذ على السطر 26 والجزئيه دى Cells( , h) تعنى انه هينفذ على العمود h وطبعا h احنا معرفينه على انه من8 الى 11 اى انه سينفذ على العمود 8 ثم العمود 9 ثم العمود10 ثم العمود11 .................................................................................................... طب حنا عايزين ننفذ الكود على العمود h اى العمود رقم 8 يبقى سطر الكود هيكون بالشكل ده Cells( , 8) وعلى السطور من 23 الى 26 وبما اننا عرفنا h على انه من 23 الى 26 يبقى سطر الكود هيصبح بالشكل ده Cells(h, ) وفى النهاية هنلاقى ان سطر الكود بالكامل بالشكل ده Cells(h,8 ) اى ان الكود سينفذ على السطور h الى احنا عرفناها على انها من 23 الى 26 وعلى العمود رقم 8 وبعد كده تأتى الجزئيه دى = h - 7 ولاننا كنا معرفين h يبدأ من الرقم 8 فطرحنا من h الرقم 7 للحصول على الرقم 1 الى هو اول رقم احنا عايزين ندخله فلا او خليه وبما اننا لسه بردو عايزين نخلى الرقم 1 هو اول رقم يتم ادخاله ولكننا قمنا بتغير قيمة المتغير h لتصبح من 23 وللحصول على الرقم 1 يبقى لابد اننا نطرح من المتغير h ما يعطينا الرقم 1 وبالتالى سنجد سطر الكود هيكون كده = h - 22 وفى النهاية سيكون شكل الكود كده Sub enterdata_for1() Dim h As Integer For h = 23 To 26 Cells(h, 8) = h - 22 Next End Sub ويكون ناتج الكود بهذا الشكل الحلقه الثانيه While سوف نتعرف على كيفيه استخدام الحلقه التكراريه While...Wend هذه الحلقه تبدأ بكلمة While وتنتهى بكلمة Wend وفيما بين الكلميتن هو ما سوف يتم تنفيذه للتوضيح اكتر While [ الشرط ] ما يتم تنفيذه Wend نهاية الحلقه فلو اننا نريد ادخال الارقام من 1 الى 4 فى السطر 38 بداية من العمود 8 كيف سيكون شكل الكود Sub EnterwhileWend() Dim h As Integer ' H--- متغير تم تعريفه على انه رقم صحيح h = 8 ' متغير تم تعريفه على انه يساوى الرقم8----- While h <= 11 ' هنا نقول ان الحلقه التكراريه تكون اقل من الرقم11او تساويه Cells(38, h) = h - 7 ' Cells(38, H)--- الرقم38هنا يدل على رقم السطر الذى سينفذ فيه الكود ' Cells(38, H)--- عباره عن العمود الذى سينفذ فيه الكود وبذلك يتضحh ' hلنا ان الكود سوف ينفذ بديةمن العمود8 لانها تساوى قيمة المتغير ' h-7 يساوى الرقم8 فحينما يتم طرحhبما ان المتغير ' الرقم7 من المتغير بذلك تصبح قيمة المتغير تساوى الرقم1 h = h + 1 'h = h + 1 هنا نقول انه يتم زياده قيمة المتغير بقيمة1صحيح مع كل ' حلقه تكراريه حتى نصل الى الشرط وهو ان يكون اقل من او يساوى11 Wend '-------'نهاية الحلقه While End Sub ويكون ناتج الكود بهذا الشكل الحلقه الثالثه Do تنقسم الى ثلاثة انواع النوع الاول Do While Loop فلو اننا نريد ادخال الارقام من 1 الى 4 فى السطر 57 بداية من العمود 8 كيف سيكون شكل الكود Sub EnterDoWhile() Dim h As Integer ' H--- متغير تم تعريفه على انه رقم صحيح h = 8 ' متغير تم تعريفه على انه يساوى الرقم8----- Do While h <= 11 ' هنا نقول ان الحلقه التكراريه تكون اقل من الرقم11او تساويه Cells(57, h) = h - 7 ' Cells(57, H)--- الرقم57هنا يدل على رقم السطر الذى سينفذ فيه الكود ' Cells(57, H)--- عباره عن العمود الذى سينفذ فيه الكود وبذلك يتضحh ' hلنا ان الكود سوف ينفذ بديةمن العمود8 لانها تساوى قيمة المتغير ' h-7 يساوى الرقم8 فحينما يتم طرحhبما ان المتغير ' الرقم7 من المتغير بذلك تصبح قيمة المتغير تساوى الرقم1 h = h + 1 'h = h + 1 هنا نقول انه يتم زياده قيمة المتغير بقيمة1صحيح مع كل ' حلقه تكراريه حتى نصل الى الشرط وهو ان يكون اقل من او يساوى11 Loop '-------'نهاية الحلقه Do While End Sub ويكون ناتج الكود بهذا الشكل النوع الثانى Do Loop While فلو اننا نريد ادخال الارقام من1 الى 4 فى السطر 67 بداية من العمود 8 كيف سيكون شكل الكود Sub EnterDo() Dim h As Integer ' H--- متغير تم تعريفه على انه رقم صحيح h = 8 ' متغير تم تعريفه على انه يساوى الرقم8----- Do Cells(67, h) = h - 7 ' Cells(67, H)--- الرقم67هنا يدل على رقم السطر الذى سينفذ فيه الكود ' Cells(67, H)--- عباره عن العمود الذى سينفذ فيه الكود وبذلك يتضحh ' hلنا ان الكود سوف ينفذ بديةمن العمود8 لانها تساوى قيمة المتغير ' h-7 يساوى الرقم8 فحينما يتم طرحhبما ان المتغير ' الرقم7 من المتغير بذلك تصبح قيمة المتغير تساوى الرقم1 h = h + 1 'h = h + 1 هنا نقول انه يتم زياده قيمة المتغير بقيمة1صحيح مع كل ' حلقه تكراريه حتى نصل الى الشرط وهو ان يكون اقل من او يساوى11 Loop While h <= 11 ' هنا نقول ان الحلقه التكراريه تكون اقل من الرقم11او تساويه '-------'نهاية الحلقه Do End Sub ويكون ناتج الكود بهذا الشكل النوع الثالث Do Until Loop فلو اننا نريد ادخال الارقام من 1 الى 4 فى السطر 77 بداية من العمود 8 كيف سيكون شكل الكود Sub EnterDoUntil() Dim h As Integer ' H--- متغير تم تعريفه على انه رقم صحيح h = 8 ' متغير تم تعريفه على انه يساوى الرقم8----- Do Until h > 11 ' هنا نقول ان الحلقه التكراريه سوف تنفذ حتى الرقم11 Cells(77, h) = h - 7 ' Cells(77, H)--- الرقم77هنا يدل على رقم السطر الذى سينفذ فيه الكود ' Cells(77, H)--- عباره عن العمود الذى سينفذ فيه الكود وبذلك يتضحh ' hلنا ان الكود سوف ينفذ بديةمن العمود8 لانها تساوى قيمة المتغير ' h-7 يساوى الرقم8 فحينما يتم طرحhبما ان المتغير ' الرقم7 من المتغير بذلك تصبح قيمة المتغير تساوى الرقم1 h = h + 1 'h = h + 1 هنا نقول انه يتم زياده قيمة المتغير بقيمة1صحيح مع كل ' حلقه تكراريه حتى نصل الى الشرط وهو ان يكون اقل من او يساوى11 Loop '-------'نهاية الحلقه Do Until End Sub ويكون ناتج الكود بهذا الشكل اتمنى ان اكون قد وفقت فى هذا الدرس انتظروا باقى الدروس تقبلوا تحياتى

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

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

السلام عليكم ورحمة الله وبركاته الدرس السادس 8-Loop الحلقات التكراريه وسوف نتناول فى هذه الدرس الاتى لماذا نستخدم الحلقات التكراريه انواع الحلقات التكراريه الخروج من الحلقه التكراريه كيفية استخدام اكثر من حلقه داخل الكود ......................................................................... لماذا نستخدم الحلقات التكراريه انا شخصيا بعتبر الحلقات التكراريه واحده من اهم المواضيع التى يجب معرفتها حينما يتم الدخول الى عالم vba يتم استخدام الحلقات التكراريه لتنفيذ اكثر من امر فى وقت واحد مما يوفر الوقت ولتوضيح ذلك راجع المثال الاتى نفترض اننا لدينا مجموعه من الارقام مثلا 7 ارقام (1-2-3-4-5-6-7) ونريد ادخال هذه الارقم فى السطر الثامن بداية من العمود الخامس اى العمود e فكيف سنقوم بعمل ذلك طبعا الى معندوش فكره عن كيفية استخدام الحلقات التكراريه هيستخدم الكود الاتى Sub enterdata() [e8] = "1" [f8] = "2" [g8] = "3" [h8] = "4" [i8] = "5" [j8] = "6" [k8] = "7" End Sub اى سيقوم بالاشاره الى كل خليه على حده واعطاء كل خليه قيمتها كما هو متضح من الصوره وبالتالى بعد كتابة هذه الكود وتخصيص زر لتنفيذه او بالوقوف داخل الكود بالماوس ثم الضغط على f5 سوف يتم ملئ الخلايا بالبيانات كما فى الصوره دعونا الان نتطرق الى كيفيه تنفيذ ذلك بالحلقات التكراريه انواع الحلقات التكراريه 1- FOR 2- WHILE 3- DO ................................................................................................................................................................................................................................................................ الحلقه الاولى for …next هذه الحلقه تبدأ بكلمة FOR وتنتهى بكلمة NEXT وفيما بين الكلميتن هو ما سوف يتم تنفيذه للتوضيح اكتر For بداية الحلقه = اسم الحلقه To طريقه تنفيذ الحلقه] نهايةالحلقه] [ماسيتم تنفيذه داخل الحلقه] [Exit For] الخروج من الحلقه Next استكمال الحلقه حت النهاية وهنا يجب ان نشير الى ان اى حلقه تكراريه لابد ان يكون لها اسم يعبر عنها وليكن مثلا H ثم يجب ان يكون لها بدايه ولها نهايه وليكن ستبدأ من 1 وتنتهى فى 10 ثم سيكون هناك ما ينفذ داخل الحلقه والمقصود بطريقة تنفيذ الحلقه اى هل سيتم تنفيذها خطوه بخطوه وهذا هو الشائع فى الاستخدام ام كل خطويتن ام كل ثلاث خطوات وهكذا ولتطبيق ذلك سنتعرف على كيفية استخدام الحلقه for فى ادخال البيانات فلو اننا نريد ادخال الارقام من 1 الى 4 فى السطر 26 بداية من العمود 8 كيف سنقوم بعمل ذلك 1-نعطى الحلقه اسم معين FOR H H 2-نحدد البدايه 8 ونحدد النهاية 11 FOR H =8 TO 11 لاحظ ان عدد الحلقات هنا 4 عباره عن 8و9و10و111 3-ماسيتم تنفيذه Cells(26, h) = h - 7 4-استكمال الحلقه NEXT وبالتالى سيكون شكل الكود كالاتى Sub enterdata_for() For h = 8 To 11 ' h----- متغير تم تعريه على انه يبدأ من 8 وينتهى عند 11 ' اى ان عدد حلقاته هى 4 عباره عن 8ثم9ثم10ثم11 Cells(26, h) = h - 7 ' هنا يتم تنفيذ الكود ' هنا نقول ان الخليه التى تقع فى السطر26 وفى العمود من8الى11 ' مطروحا منه 7 ارقام ليصبح قيمة المتغير تساوى1hتساوى قيمة المتغير ' Cells(26, H)--- الرقم26هنا يدل على رقم السطر الذى سينفذ فيه الكود ' Cells(26, H)--- عباره عن العمود الذى سينفذ فيه الكود وبذلك يتضحh ' hلنا ان الكود سوف ينفذ على الاعمده من 8الى11 لانها تساوى قيمة المتغير ' h-7 يبدأ من الرقم8وينتهى عند الرقم11 فحينما ينم طرحhبما ان المتغير ' الرقم7 من المتغير بذلك تصبح قيمة المتغير تبدأ من الرقم1وتنتهى عند الرقم4 'وبذلك يكون تنفيذ الكود كالاتى ' الخليه فى السطر26وفى العمود5تساوى الرقم1ثم ' الخليه فى السطر26وفى العمود6تساوى الرقم2ثم ' الخليه فى السطر26وفى العمود6تساوى الرقم3ثم ' وهكذا حت نصل الى اخر الحلقه التكراريه اى العمود11 Next ' hتكرار عمل الكود حتى نهاية المتغير ' next---- forاقفال الحلقه التكراريه End Sub ويكون ناتج الكود بهذا الشكل اما اذا اردنا تنفيذ الكود على الخلايا بشكل عمودى بدلا من الخلايا الافقيه بمعنى لو اننا اردنا مثلا تنفيذ نفس الكود على الخلايا من h23 الى h26 اى فى الخلايا h23 و h24 و h25 و h26 كيف سيكون شكل الكود الكود هيكون نفس الكود السابق ولكن ما سيختلف هو اننا سوف نعيد تغير قيمة المتغير h الخاص بالحلقه التكراريه ليصبح من 23 الى 26 ثم نقوم بتغير موضع المتغير h الخاص بالحلقه التكراريه من الصف الى العمود للتوضيح اكثر الفكره هكلها محصوره فى السطرين دول For h = 8 To 11 هنا طبعا قيمة المتغير h الخاص بالحلقه التكراريه من 8 الى 11 احنا عايزين نخليه يبقى من 23 الى 26 يبقى هيكون بالشكل ده For h = 23 To 26 وكمان فى السطر ده Cells(26, h) = h - 7 وطبعا احنا قولنا ان الجزئيه دى Cells(26 تعنى ان الكود سوف ينفذ على السطر 26 والجزئيه دى Cells( , h) تعنى انه هينفذ على العمود h وطبعا h احنا معرفينه على انه من8 الى 11 اى انه سينفذ على العمود 8 ثم العمود 9 ثم العمود10 ثم العمود11 .................................................................................................... طب حنا عايزين ننفذ الكود على العمود h اى العمود رقم 8 يبقى سطر الكود هيكون بالشكل ده Cells( , 8) وعلى السطور من 23 الى 26 وبما اننا عرفنا h على انه من 23 الى 26 يبقى سطر الكود هيصبح بالشكل ده Cells(h, ) وفى النهاية هنلاقى ان سطر الكود بالكامل بالشكل ده Cells(h,8 ) اى ان الكود سينفذ على السطور h الى احنا عرفناها على انها من 23 الى 26 وعلى العمود رقم 8 وبعد كده تأتى الجزئيه دى = h - 7 ولاننا كنا معرفين h يبدأ من الرقم 8 فطرحنا من h الرقم 7 للحصول على الرقم 1 الى هو اول رقم احنا عايزين ندخله فلا او خليه وبما اننا لسه بردو عايزين نخلى الرقم 1 هو اول رقم يتم ادخاله ولكننا قمنا بتغير قيمة المتغير h لتصبح من 23 وللحصول على الرقم 1 يبقى لابد اننا نطرح من المتغير h ما يعطينا الرقم 1 وبالتالى سنجد سطر الكود هيكون كده = h - 22 وفى النهاية سيكون شكل الكود كده Sub enterdata_for1() Dim h As Integer For h = 23 To 26 Cells(h, 8) = h - 22 Next End Sub ويكون ناتج الكود بهذا الشكل اتمنى ان اكون قد وفقت فى هذا الدرس انتظروا باقى الدروس تقبلوا تحياتى

أستادي الفاضل أنس جربت على عجالة الملف على أوفيس 32/2010 ويندوز 64 بت في احدى السيبيرات و بالفعل الملف لم يعمل كما تفضلت ولم تتغير الشفافية للأسف بدون توفري على جهاز فيه الويندوز 64 لن أتمكن بسهولة من معرفة سبب المشكلة .. احدى مشاكل برمجة ال API هي تعدد اصدارات الاوفيس و الويندوز .. ان شاء الله قريبا سأتوفر على جهاز جديد يعمل على الويندوز 64 و سأقوم بتعديل كل الكودات

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

تم بفضل الله شاكر مرورك ومساعدتك اخي صلاح المصري

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

جرب المرفق عمل بطاقة للموظف والمدرسة1.rar

وعليكم السلام أخي للأسف ، هذه مشكلة في الاكسس ، في النموذج المستمر ، عندما يأخذ مربع السرد والتحرير قيمته استنادا على حقل آخر الحل هو: اعمل نسخة من SQL استعلام مربع سرد وتحرير حقل الوحدة ، اعمل استعلام جديد ، انا اسميته qry_INV100_Unite ، اعمل النموذج المستمر frm_INV100_Unite ، اللي يأخذ بياناته من الاستعلام qry_INV100_Unite ، في النموذج الفرعي INV100 ، احذف المعيار من حقل الوحدة ، في الحدث "بعد التحديث" للحقل "رمز المادة" ، افتح النموذج frm_INV100_Unite (والذي سيكون مصفى حسب "رمز المادة" ، اضغط على زر Ok للمادة التي تريدها ، وسترى ان القيمة انتقلت لحقل الوحدة في النموذج الفرعي INV100 ، وسيغلق النموذج frm_INV100_Unite سهله هه جعفر 220.البرنامج.accdb.zip

اخى عبد الناصر جرب الكود الاتى وهذا على حسب فهمى للمطلوب ............................................... اذا لم يفى الكود بالمطلوب يرجى وضع مرفق به مثال لما تريد Sub trs_invoice() Application.ScreenUpdating = False Dim LR As Long, LR1 As Long Dim WS As Worksheet Dim WS1 As Worksheet Set WS = Worksheets("فاتورة بيع") Set WS1 = Worksheets("ترحيل الفاتورة") LR1 = WS1.Range("c55555").End(xlUp).Row + 1 Dim FR For R = 3 To LR1 If WS1.Cells(R, 3) = WS.Range("f6") Then MsgBox "This invoice already exist, No shift will done": Exit Sub Next For FR = 11 To 27 If WS.Cells(FR, 2) = "" Then GoTo 7 WS1.Cells(LR1, 2) = WS.Range("F7").Value WS1.Cells(LR1, 3) = WS.Range("F6").Value WS1.Cells(LR1, 4) = WS.Range("C6").Value WS1.Cells(LR1, 5) = WS.Range("C7").Value WS.Range("B" & FR & ":H" & FR).Copy WS1.Range("F" & LR1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False WS1.Range("M" & LR1).Value = WS1.Range("H" & LR1) - WS1.Range("L" & LR1) LR1 = LR1 + 1 7 Next FR Application.CutCopyMode = False WS.Select Application.ScreenUpdating = True End Sub تقبل تحياتى

تسلم الايادى اللى بتعمل برمجه بتنادى ... تحيه للصعايده الجدعان واولهم الاستاذ مختار

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

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

السلام عليكم ورحمة الله قمت بتبديل الدالة VLOOKUP بدالة أخرى OFFSET مع الدالة MATCH مع تعديلات على تنسيقات شيتات الملف... بن علية خط سير شهرى3.rar

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

الرجاء إرفاق الملف للاطلاع عليه وحل المشكلة

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

اخى الفاضل تفضل تم الغاء تظليل البيانات وعدم الترحيل اذا كانت بعض الخلايا فارغة وهي رقم الموظف وكود الدورة وبدايتها تحياتي نموذج ترشيحات العاملين للبرامج التدريبي4.rar

السلام عليكم تم بحمد الله الانتهاء من الحلقة الرابعة عشر http://www.officena.net/ib/index.php?showtopic=57094&page=11#entry378087 دمتم بود

السلام عليكم ورحمة الله وبركاته استاذي الكريم الف شكر لك لردك ومساعدتك الكود يعمل على جميع الاوراق ولا يمسح ماتم ترحيله مسبق لكن اذا تكرمت علي اريد فقط ترحيل الصف الاخير من الورقة والكود يقوم بترحيل كامل البيانات داخل الصفحة المتطابقة داخل الخلية k والمطلوب فقط ترحيل السطر الاخير واذا كان في الامكان الا يقوم بترحيل السطر الاخير اذا كان مرحل سابقا الى مشروع تم ترحيله عليه مثلا تم ترحيل السطر الاخير من مشروع الوليد الى مشروع 147 وبعدها لم يتم اضافة سطر اخر في مشروع الوليد وتم الضغط على كلمة ترحيل لا يسمح بتنفيذ عملية الترحيل السطر الاخير والموجه الى مشروع 147 لان هذه البيانات موجودة مسبقا في نفس المشروع ويسمح بترحيلها اذا تم تغير اسم المشروع المرسل اليه مثلا الى 146 ارجو ان اكون وضحت طلبي وارجو مساعدتي ولك جزيل الشكر مني وعليكم السلامورحمة الله وبركاته استخدم فقط هذا الكود Option Explicit Sub kh_Trheel() Dim NamSheet As String Dim Last As Long ''''''''''''''''''''''' On Error GoTo kh_ExT Last = Cells(Rows.Count, "A").End(xlUp).Row NamSheet = CStr(Cells(Last, "K")) If Not IsError(Evaluate("'" & NamSheet & "'!A1")) Then With Sheets(NamSheet) If CStr(.Cells(Rows.Count, "K").End(xlUp)) = NamSheet Then MsgBox "مكرر": Exit Sub Else Cells(Last, "A").Resize(1, 11).Copy .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) End If End With End If ''''''''''''''''''''''' ''''''''''''''''''''''' kh_ExT: If Err Then MsgBox "Error Number : " & Err.Number Err.Clear Else MsgBox "الحمد لله تم الترحيل" End If ''''''''''''''''''''''' End Sub المرفق 2003 تحياتي ترحيل صف الى ورقة معينة حسب خلية معينة.rar

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

أخي العزيز، تم عمل كود يقوم بترحيل ما في النموذج من ورقة "الرئيسي" إلى ورقة "الكل" ثم إلى الورقة المحددة بالخلية F2 (مرسل إلى) وبعد عملية الترحيل يقوم الكود بتفريغ كل البيانات في النموذج... تم حفظ الملف بصيغة xlsb بدلا من صيغة xlsm... أرجو أن يعجبك الملف وكل هذه الإضافات.... المرفق: قائمة الشحن.rar

الاخوة الأعزاء كل عام وأنتم بخير أرجو منكم المساعدة في الملف المرفق الذي يحتاج مجموعة أكواد حسب الشرح الموجود في الملف Vacation222.rar

السلام عليكم ما الخطأ فى هذا الكود و شكرا بيانات اعدادى.rar

اخي الشهابي تم إنشاء موضوع جديد للفائدة ممكن ذلك تفضل المرفق (تم عمل قائمة منسدلة متجدد ومهما اضفت من أوراق عمل ستجدها تلقائياً في القائمة المنسدلة) جرب واعلمني بالنتيجة ابواحمد ترحيل الى اوراق مختارة.rar

السلام عليكم اكرر ان لم يكن المطلوب بلغنى لا تنسى فتح المرفقين معاً Dim MyRNG As Range Set MyRNG = Selection If MyRNG.Interior.ColorIndex = 6 Then MsgBox "áÞÏ Êã ÊÑÍíá ÇáäØÇÞ" & vbCrLf & MyRNG.Address(0, 0) & vbCrLf & "ãÓÈÞÇð" Exit Sub End If For A = 1 To MyRNG.Rows.Count D = Workbooks("ãÍá22").Sheets(1).Cells(1000, 1).End(xlUp).Row + 1 For B = 1 To MyRNG.Columns.Count Workbooks("ãÍá22").Sheets(1).Cells(D, B) = MyRNG.Cells(A, B) Next B Next A MyRNG.Interior.ColorIndex = 6 محل11.rar