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

وعبى يابا

وعليكم السلام ورحمة الله تعالى وبركاته بعد إذن صاحب الملف أستادنا الكبير @ضاحي الغريب وتجنبا للتعديل على الأكواد الخاصة به رغم أنني متأكد أنه تم التلاعب بها مسبقا قمت بحدف جميع الأكواد الموجودة داخل اليوزرفورم وإعادة ترتيب تسلسل عناصر TEXTBOX بما يتناسب مع شكل وتصمييم الملف وإنشاء أكواد جديدة بطريقتي الخاصة و إظافة بعض اللمسات مع الاحتفاظ على نفس فكرة إشتغال اليوزرفورم تفضل اخي @ehabaf2 أتمنى أن يلبي طلبك Dim Btn(1 To 5) As New ClasseBoutons Dim ExitLoop As Boolean Const dict As Integer = 61 Private Const b As Long = 1 Private Const SearchColumn As String = "A" Public Property Get WS() As Worksheet: Set WS = Sheets("DATA"): End Property Private Sub UserForm_Initialize() For i = 1 To 5 Set Btn(i).GrBoutons = Me("commandbutton" & i) Next i Dim temp() Col = WS.Evaluate("SUM(0+(A5:A" & _ WS.Cells(WS.Rows.Count, "A").End(xlUp).Row & "<>""""))") Set tbl = CreateObject("Scripting.Dictionary") For Each c In WS.Range("A4:A" & WS.[a65000].End(xlUp).Row) If c.Value <> "" Then tbl.Item(c.Value) = c.Value Next c temp = tbl.items Tri temp, LBound(temp), UBound(temp) Me.ComboBox1.List = temp Me.limite.Value = Col End Sub '**************************** Private Sub ComboBox1_Change() ' بجث وجلب البيانات Dim fnd As Range, i As Long, sequence As String sequence = Me.ComboBox1 If Len(sequence) = 0 Then Exit Sub If IsNumeric(sequence) Then Set fnd = WS.Columns(SearchColumn).Find(sequence, , , xlWhole) If fnd Is Nothing Then MsgBox "! لم يتم العثور على رقم التسلسل " & " : " & _ sequence & " " & "في قاعدة البيانات", 16, "تم ايقاف تنفيد الكود" Me.ComboBox1 = "" Exit Sub End If For i = 1 To dict Me.Controls("TextBox" & i).Value = fnd.Offset(, i - b).Value Next i End If End Sub '************************************ Private Sub CommandButton1_Click() ' ترحيل Dim i As Long, src As Range Set src = WS.Range("A" & WS.Rows.Count).End(xlUp) If Me.TextBox3 = "" Then: MsgBox "يرجى اظافة " & ":" & Me.Label2.Caption, 16: Exit Sub r = MsgBox("ترحيـل البيانات؟", vbYesNo, "تأكيـــد"): If r <> vbYes Then Exit Sub For i = 1 To dict Application.ScreenUpdating = False src.Offset(b, i - b).Value = Me.Controls("TextBox" & i).Value With WS.Range("A5:A" & WS.Cells(WS.Rows.Count, "C").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-4") End With Me.Controls("TextBox" & i).Value = Null: Me.ComboBox1 = Empty Next i UserForm_Initialize Application.ScreenUpdating = True End Sub '******************************** Private Sub CommandButton3_Click() 'حدف Dim sequence As String sequence = Me.ComboBox1 If Len(sequence) = 0 Then Exit Sub r = MsgBox("حدف البيانات؟", vbYesNo, "تأكيـــد"): If r <> vbYes Then Exit Sub Application.ScreenUpdating = False With WS For i = .[a65000].End(xlUp).Row To 5 Step -1 If .Cells(i, (SearchColumn)) = sequence Then .Cells(i, 1).Resize(1, 61).Delete Shift:=xlUp Next i With Range("A5:A" & .Cells(.Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-4") End With End With Clear_TextBox Application.ScreenUpdating = True UserForm_Initialize End Sub '******************************** Private Sub CommandButton2_Click() ' تعديل Dim fnd As Range, sequence As String Dim i As Integer sequence = Me.ComboBox1 If Len(sequence) = 0 Then Exit Sub r = MsgBox("تعديل البيانات؟", vbYesNo, "تأكيـــد"): If r <> vbYes Then Exit Sub Application.ScreenUpdating = False Set fnd = WS.Columns(SearchColumn).Find(sequence, , , xlWhole) For i = 1 To dict WS.Cells(fnd.Row, i) = Controls("textbox" & i).Value Next i Clear_TextBox Application.ScreenUpdating = True UserForm_Initialize End Sub ملاحظة : أكواد البحث و التعديل والحدف يتم تنفيدها بشرط عمود التسلسل / الترحيل بشرط وجود قيمة في Textbox رقم الموظف واي اظافة او تعديل لا تتردد في دكره سنكون سعداء دائما بحصولك على النتائج المتوقعة لقد تركت لك إمكانية وضع توقيعك على اليوزرفورم 😃😃😃 بالتوفيق............ ملف ترحيل بالفورم V2.xlsm

السلام عليكميكفي تغيير المعادلة في الخلية C26 في شيت Dashboard والتي هي : E22&""= بالمعادلة : E22= كما في الملف المرفق... بيان الربح والخسارة_Copy (3).xlsx

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

تفضل اتمنى تكون بداية خير لك لاحتراف اكسس db1.rar

تفضل أخي قمت بتطوير النموذج ليحمل أزرار فرعية وأزرار فرعية من الفرعية 🙂 وهذه لوحة التحكم : ملاحظة : تم تحديث رابط التحميل في أول مشاركة 🙂

أخي الكريم يرجى ارفاق ملف إكسيل بالمطلوب للعمل عليه

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

مجهود رائع وربنا يبارك فيك استاذنا الغالي ..... وربي يزيدك من علمه وفضله

جرب هذا الرابط https://answers.microsoft.com/en-us/msoffice/forum/all/how-to-enter-numbers-in-excel-spreadsheet-using/d8c92930-b468-410e-bc30-b0f527d02d6e ثم استخدم Windows Speech Recognition

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

السلام عليكم ورحمة الله تم تعديل المعادلات حسب طلبك ... داش بورد تحليل المصروفات.xlsx

احيانا الاعتماد على التاريخ للترقيم يسبب بعض المشكلات لذا تم تحويل التاريخ الى رقم من اجل زيادة ضبط المعادلة Database1 (1).rar

جرب هدا Sub Print_Tbl() Dim lr As Long Set WS = Sheets("ELRASHIDY") Application.ScreenUpdating = False With WS .ResetAllPageBreaks lr = WS.Columns("B:X").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row Application.PrintCommunication = False With WS.PageSetup .PrintArea = WS.Range("B2:X" & lr).Address .FitToPagesWide = 1 .FitToPagesTall = 1 End With End With Application.PrintCommunication = True Application.ScreenUpdating = True ActiveWindow.SelectedSheets.PrintPreview 'WS.PrintOut Copies:=1 End Sub اخي لقد حاولت حدف الاعمدة الغير مستخدمة مما سيجبرني على تعديل الكود السابق بما يناسب التصمييم الجديد Sub my_date() Dim xDate As String, i As Long Set sh = Sheets("ELRASHIDY") Do xDate = InputBox("insert date format month/year ", "insert month date", "MM/YYYY") If StrPtr(xDate) = 0 Then Exit Sub If xDate = "MM/YYYY" Then MsgBox "يرجى ٌإدخال التاريخ", 48 Loop While xDate = "MM/YYYY" If Not IsDate(xDate) Or Not (xDate) Like "##/####" Then _ MsgBox "يرجى التحقق من التاريخ", 16: Exit Sub Application.ScreenUpdating = False With sh .Range("A6:B36,I6:J36").ClearContents cnt = DateSerial(Year(xDate), Month(xDate), 1) arr = Array("A6", "I6", "G4", "O4") tmp = DateSerial(Year(xDate), _ Month(xDate) + 1, 1) - cnt For i = LBound(arr) To UBound(arr) .Range(arr(i)).Value = cnt Next i [A6].AutoFill Destination:=[A6].Resize(tmp), Type:=xlFillDays [I6].AutoFill Destination:=[I6].Resize(tmp), Type:=xlFillDays For i = 6 To sh.Cells(Rows.Count, "A").End(xlUp).Row ColDates = Range("A" & i).Value DayName = Format(ColDates, "dddd") With Union(sh.Range("B" & i), sh.Range("J" & i)) .Value = DayName End With Next i End With Application.ScreenUpdating = True End Sub Sub PrintTb2() Dim lr As Long Set WS = Sheets("ELRASHIDY") With WS .ResetAllPageBreaks lr = .Cells(.Rows.Count, "a").End(xlUp).Row Application.PrintCommunication = False With WS.PageSetup .PrintArea = WS.Range("A2:O" & lr).Address .FitToPagesWide = 1 .FitToPagesTall = 1 End With Application.PrintCommunication = True WS.PrintPreview 'WS.PrintOut Copies:=1 End With End Sub SHADY TIME TABLE 1_V4.xls

وعليكم السلام ورحمة الله تعالى وبركاته رغم انه في وجهة نظري ان الاقتراح المقدم من اخينا @AbuuAhmed افضل واسهل وينفد المطلوب دون الحاجة لاستخدام صندوق الادخال في حالة كانت لك رغبة لاستخدام نفس الطريقة يمكنك تجربة هدا Sub my_date() Dim xDate As String, i As Long Set sh = Sheets("ELRASHIDY") xDate = InputBox("insert date format month/year ", "insert month date", "MM/YYYY") If StrPtr(xDate) = 0 Then Exit Sub If Not IsDate(xDate) Or Not (xDate) Like "##/####" Then _ MsgBox "يرجى التحقق من تاريخ الادخال", vbExclamation: Exit Sub Application.ScreenUpdating = False With sh .Range("B6:C36,N6:O36").ClearContents tmp = DateSerial(Year(xDate), _ Month(xDate) + 1, 1) - DateSerial(Year(xDate), Month(xDate), 1) Range("B6,N6,I4").Value = DateSerial(Year(xDate), Month(xDate), 1) [B6].AutoFill Destination:=[B6].Resize(tmp), Type:=xlFillDays [N6].AutoFill Destination:=[N6].Resize(tmp), Type:=xlFillDays For i = 6 To sh.Cells(Rows.Count, "b").End(xlUp).row ColDates = Range("b" & i).Value DayName = Format(ColDates, "dddd") With Union(sh.Range("C" & i), sh.Range("O" & i)) .Value = DayName End With Next i End With Application.ScreenUpdating = True End Sub SHADY TIME TABLE 1_V2.xls

اشكرك على الرد jiofi.local.html tplinklogin

فقط أدخل تاريخ الشهر في الخلية "I4" SHADY TIME TABLE 1_01.xls

To disable the Esc key Application.EnableCancelKey = xlDisabled To re-enable it Application.EnableCancelKey = xlInterupt