إبراهيم ابوليله

اخى محمد ----------------- السلام عليكم ورحمة الله وبركاته ----------------------------- احيانا الاكسيل بيعمل حاجات غريبه ------------------------------------------- على العموم انا قمت بعمل المطلوب وذلك بعد نقل البيانات الى شيت جديد حيث ان الشيت الاصلى كان به مشكله ايه هى الله اعلم -------------------------------------------------- جرب المرفق 25Q.rar

اخى جلال اخى محمود الشريف الاخت ام عبدالله ---------------------اشكركم على تنوع الحلول افكار جميله واسلوب راقى فى التعامل مع بعضنا -------------------------------------- نحمد الله على تواجدنا فى هذا الصرح الكبير الذى تعلمنا منه الكثير ----------------------------- بارك الله فيكم جميعا --------------- اسمحو لى بالمشاركه فى الحل بطريقه اخرى البحث بين تاريخيين-1.rar

اخى طاهر وعليكم السلام ورحمه الله وبركاته -------------------- ارجو النظر والرعوع الى المشاركه رقم8 ستجدنى قد كتبت لك اعتقد انه ليس هناك داعى لوجود هذه الرساله لانك اذا قمت بكتابة رقم1مثلا فى التيكست بوكس وكان هذا الاذن قد تم تسجيله من قبل فسوف تجد ان الزر الخاص بتسجيل عمليه جديده قد اصبح غير نشط بحيث لا يمكنك استخدامه وبالتالى لم يعد امامك غير اما ات تقوم بالتعديل او ان تقوم بالحزف وبالتالى فلن يحدث مطلقا ان يتم تسجيل اذن مرتين ----------------------------------------------- وبالتالى فلن تجد تاثير ملحوظ للكود وقد ارفقت لك الكود للتعلم طريقه كتابته فقط ---------------------------------- اما بالنسبه لكود ملئ الشاشه فهذا افضل كود للاخ ابو حنين استاذنا الكبير بارك الله فيه ----------------------------------- قم باضافة موديول جديده ثم قم بارفقا الكود الاتى داخلها 'كود جعل الفورم ملئ الشاشه ليتناسب مع جميع الاجهزه Public largeurbouton(), hauteurbouton(), leftbouton(), topbouton(), tcaractere(), couleurbouton(), couleurtext() As Long Public ctrl As Control Public maform As Object Public i, largeure_usf, hauteure_usf As Long Private Declare Function GAW Lib "user32" Alias "GetActiveWindow" () As Long Private Declare Function GWL Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SWL Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Const GWL_STYLE As Long = -16 'ajoute le full option au style Private Const WS_FULL_OPTION = &H70000 'Les 3 boutons et l'elasticité Sub troisbouton() 'كود جعل الفورم ملئ الشاشه ليتناسب مع جميع الاجهزه Whdl = GAW 'Acquisition du Handle de la Userform forme = GWL(Whdl, GWL_STYLE) 'Acquisition propriétés SWL Whdl, GWL_STYLE, forme Or WS_FULL_OPTION 'toute les options(trois bouton et elasticité) TextBox1 = GAW End Sub Sub determine() 'كود جعل الفورم ملئ الشاشه ليتناسب مع جميع الاجهزه hauteure_usf = maform.Height largeure_usf = maform.Width i = 0 For Each ctrl In maform.Controls i = i + 1 On Error Resume Next ReDim Preserve largeurbouton(i) largeurbouton(i) = maform.Width / ctrl.Width ReDim Preserve hauteurbouton(i) hauteurbouton(i) = maform.Height / ctrl.Height ReDim Preserve topbouton(i) topbouton(i) = maform.Height / ctrl.Top ReDim Preserve leftbouton(i) leftbouton(i) = maform.Width / ctrl.Left ReDim Preserve tcaractere(i) ' tcaractere(i) = ctrl.Width / ctrl.Font.Size Next End Sub Sub redimentionnement() 'كود جعل الفورم ملئ الشاشه ليتناسب مع جميع الاجهزه On Error Resume Next i = 0 For Each ctrl In maform.Controls i = i + 1 ctrl.Width = maform.Width / largeurbouton(i) ctrl.Height = maform.Height / hauteurbouton(i) ctrl.Left = maform.Width / leftbouton(i) ctrl.Top = maform.Height / topbouton(i) ctrl.Font.Size = ctrl.Width / tcaractere(i) Next maform.Repaint 'repeint le userform pour effacer les traces des anciens emplacement des control _ (du a la puissance de la carte graphique la plus part du temp) End Sub ثم فى حدث الفورم ضع الاكود الاتيه Private Sub UserForm_Activate() 'كود جعل الفورم ملئ الشاشه ليتناسب مع جميع الاجهزه Set maform = Me determine troisbouton '=============================================== End Sub Private Sub UserForm_Initialize() 'كود جعل الفورم ملئ الشاشه ليتناسب مع جميع الاجهزه Set maform = Me determine troisbouton '=============================================== End Sub Private Sub UserForm_Resize() 'كود جعل الفورم ملئ الشاشه ليتناسب مع جميع الاجهزه redimentionnement '=============================================== End Sub ثم قرب مؤشر الفأرة من علامة X في الفورم و اضغط على تكبير

اخى واستاذنا جمال دائما ما تاتى بكل ماه جديد انت بالفعل ملك المعادلات --------------------------------- بارك الله لنا فيك ---------------------------------- اسمح لى بالمشاركه البحث بين تاريخيين.rar

اخى طاهر السلام عليكم ورحمه الله وبركاته ------------------------------------ النسبه لسؤالك الاول 1- عند الضغط على زر التعديل يتم ترحيل البيانات نص مما يجعلها .................................................... تم معالجه الامر -------------------------------------------------------------- بالنسبه للسؤال الثانى 2-هل من الممكن ان يفتح " يظهر "الفورم على صفحة رقم 1 بدلا من صفحة ادخال البيانات ........................................................................................................ ممكن طبعا ولكن ضمانا للسلامة البيانات التى سوف يتم استدعائها عند البحث تجبرنا على ان تكون الصفحه النشطه هى صفحة البيانات -------------------------------------------------------------------------------------------------------------------------- اما بالنسبه للسؤال الثالث ان تظهر رسالة التحزير اذا كان الاذن موجود من قبل ونصها " هذا الاذن مسجل من قبل " ........................................................................................................ اعتقد انه ليس هناك داعى لوجود هذه الرساله لانك اذا قمت بكتابة رقم1مثلا فى التيكست بوكس وكان هذا الاذن قد تم تسجيله من قبل فسوف تجد ان الزر الخاص بتسجيل عمليه جديده قد اصبح غير نشط بحيث لا يمكنك استخدامه وبالتالى لم يعد امامك غير اما ات تقوم بالتعديل او ان تقوم بالحزف وبالتالى فلن يحدث مطلقا ان يتم تسجيل اذن مرتين ------------------------------------------------------------ وعلى العمود فقد اضفت الكود الاتى فى زر التسجيل يمكنك الاطلاع عليه زياده فى المعرفه لا اكثر If WorksheetFunction.CountIf(Sheets("sheet2").[A10:A10000], TextBox1) <> 0 Then MsgBox "ÇáßæÏ ÇáÐì ÇÏÎáÊå ãßÑÑ" & vbNewLine & "----------------------------" _ & vbNewLine & "ERROR CODE NO is exits", vbInformation, "ÎØÃ" Exit Sub End If فى امان الله مصروفات.rar

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

الاخت ام عبدالله الف مليون مبروك ترقيه مستحقه ومن تقدم الى تقدم فى امان الله

اخى جلال بارك الله فيك زياده فى الخير مقبوله باذن الله

اخى محمد السلام عليكم ورحمه الله وبركاته هذه طريقه اخرى باسخدام الاكواد SRIAL 1_2_2.rar

اخى محمد السلام عليكم ورحمه الله وبركاته هذه طريقه اخرى SRIAL 1_2.rar

اخى محمد السلام عليكم ورحمه الله وبركاته هل تقصد هكذا SRIAL 1.rar

اخى ممكن توضح المطلوب اكثر

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

اخى طاهر السلام عليكم ورحمه الله وبركاته هل تقصد هكذا تفضل مصروفات.rar

اخى وعليكم السلام ورحمه الله وبركاته -------------------------------+ اولا لك من دعوه طيبه للالتزام بقواعد المنتدى ومنها ان تكون اسماء الظهور باللغه العربيه بارك الله فيك --------------------------------------- ثانيا هذه محاوله منى ارجو ان تفى بالغرض SRIAL 1.rar

الاخوه الافاضل اريد معرفة كيفيه ترحيل الصوره من الليبل الموجود فى الفورم الى الخليه A1

اخى جلال انا شخصيا سعيد بمشاركتك واستفدت منها بارك الله فيك

اخى محمد هل تقصد هكذا Book200.rar

اخى محمود بارك الله فيك كود جميل وسهل يتسم بالبساطه ---------------------- اسمح لى بالمشارك بكود عن طريق الحلقه التكراريه ---------------------------------- Sub MoveData() Dim EndRow As Long If Sheets("Employee Profile").Range("B5").Value = "" Or Sheets("Employee Profile").Range("L8").Value = "" Or Sheets("Employee Profile").Range("L9").Value = "" Or Sheets("Employee Profile").Range("L10").Value = "" Or Sheets("Employee Profile").Range("L11").Value = "" Or Sheets("Employee Profile").Range("L12").Value = "" Or Sheets("Employee Profile").Range("L13").Value = "" Or Sheets("Employee Profile").Range("L16").Value = "" Then MsgBox prompt:="ÊÃßÏ ãä ÅÏÎÇá ßÇÝÉ ÇáÈíÇäÇÊ", Title:="ÎØÃ" Else EndRow = Sheets("DATA").Range("A1").CurrentRegion.Rows.Count Sheets("DATA").Cells(EndRow + 1, 1).Value = EndRow Sheets("DATA").Cells(EndRow + 1, 2).Value = Sheets("Employee Profile").Cells(8, 12).Value Sheets("DATA").Cells(EndRow + 1, 3).Value = Sheets("Employee Profile").Cells(5, 2).Value X = 4 For H = 9 To 16 Sheets("DATA").Cells(EndRow + 1, X) = Sheets("Employee Profile").Cells(H, 12).Value X = X + 1 Next MsgBox prompt:="Êã ÊÑÍíá ÇáÈíÇäÇÊ ÈäÌÇÍ", Title:="ÑÓÇáÉ ÊÃßíÏ" End If End Sub نموذج تعبئة11.rar

اخى طاهر تم عمل المطلوب مع اضافة زر للحزف ------------------- اما بالنسبه للنتيجه فلاسف لم ينج الامر معى --------------- تفضل مصروفات.rar

اخى صلاح هنا اقول لك ليس لى علم بهذا كنت اتمنى ان استطيع مساعدتك ولكن اعزرنى

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

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

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

اخى صلاح يمكنك عمل ذلك بنفسك سواء اذا كنت تريد استخدام الكود الاول او الكود الثانى -------------------------------------- اذا اردت استخدام الكود الاول قم بتغير هذا السطر Private Sub Workbook_BeforeClose(Cancel As Boolean) الى Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) --------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- فى حالة استخدام الكود الثانى فقط قم بحزف هذا الكود Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.DisplayFullScreen = False Application.DisplayFormulaBar = True Dim Msg Dim MyPath As String, pt As String MyName = ActiveWorkbook.Name MyRev = StrReverse(MyName) MyTep = StrReverse(Left(MyRev, InStr(MyRev, "."))) MyDate = Chr(32) & Format(Date, "dd-mm-yy") MyName = Trim(Replace(MyName, MyTep, "")) Text_ = MyName & MyDate '============================ MyPath = ActiveWorkbook.Path & "\" & Trim(Text_) & MyTep pt = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name '============================ ActiveWorkbook.SaveCopyAs MyPath '============================ End Application.Visible = True End Sub