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

وعليكم السلام -تفضل بهذه المعادلة سحباً لليسار ثم الى الأسفل =COUNTIFS(data!C$2:C$1000,"<>"&"",data!$A$2:$A$1000,$B4,data!$B$2:$B$1000,1) trasnport1.xlsx

:: السلام عليكم ورحمة الله وبركاته :: 🙂 يطيب لي أن أهديكم هذه الهدية البسيطة 🎁 :: مرسال الواتسأب :: وهو برنامج بسيط جدا لإرسال الرسائل عن طريق الواتسأب .. مع إمكانية إرسال المرفقات كذلك ( صور أو مستندات ) 🙂 وله واجهتين رئيسيتين : 1 - الرسائل الفردية 2 - الرسائل الموجهة لعدة أشخاص :: وهذه صور لواجهات البرنامج :: طبعا من الضروري تنصيب برنامج الواتسأب للكمبيوتر وتشغيله قبل تشغيل البرنامج 🙂 وبملاحظاتكم ودعواتكم دوما نرتقي 🙂 :: وأخيرا :: التحميل :: ☺️👌🏼 مرسال الواتسأب.accdb

السلام عليكم إخوتي الكرام بعد إذن الأخ الكريم الذي وصل إلى النتيجة ، إليكم طريقة أخرى بمعادلة واحدة فقط =IF(1*TEXT(EOMONTH(TODAY();0);"dd")>30;EOMONTH(TODAY();0)-4-TODAY()&"يوم";IF(1*TEXT(EOMONTH(TODAY();0);"dd")=30;EOMONTH(TODAY();0)-3-TODAY()&"يوم";IF(1*TEXT(EOMONTH(TODAY();0);"dd")=29;EOMONTH(TODAY();0)-2-TODAY()&"يوم";IF(1*TEXT(EOMONTH(TODAY();0);"dd")=28;EOMONTH(TODAY();0)-1-TODAY()&"يوم")))) وهناك معادلة أخرى فقط للملاحظة قد لا يحتاجها الأخ السائل: =" باقي"&$C$5&" "&"بناء على تاريخ نزول الراتب والذي يوافق يوم 27 من كل شهر ميلادي" والله ولي التوفيق ..والسلام عليكم موعد الرواتب.xlsx

السلام عليكم 🙂 اخي ابو احمد @AbuuAhmed اسمح لي اكون اول من يُهنّيك على الترقية 🙂 هي مجرد القاب للمحترفين ، وتعريف الباقين بكم 🙂 جعفر

وعليكم السلام 🙂 كود اخوي موسى ، ولكن بطريقتي 🙂 Sub CopyFile() Dim sPathDeskTop As String sPathDeskTop = Environ("USERPROFILE") & "\Desktop" & "\b\" ' هنا اسم المجلد الذي سيتم انشاؤه في سطح المكتب Dim CopyFrom As String, CopyTo As String CopyFrom = Me.a ' هذا اسم الحقل الذي به رابط الملف المراد نسخه CopyTo = sPathDeskTop & Dir(CopyFrom) If Len(Dir(sPathDeskTop, vbDirectory)) = 0 Then MkDir (sPathDeskTop) If Len(Dir(CopyTo, vbDirectory)) = 0 Then FileCopy CopyFrom, CopyTo Else MsgBox "هذا الملف موجود مسبقا على سطح المكتب", vbOKOnly Exit Sub End If End Sub جعفر

وعليكم السلام 🙂 ان شاء الله طريقتي تعجبك 🙂 . . Private Sub VeiwReportBtn_Click() On Error GoTo Err_VeiwReportBtn_Click Dim qry_0 As String, qry_1 As String qry_0 = "Select * From qry_Table2_Empty_One_Record" qry_1 = "Select * From qry_Table2" DoCmd.DeleteObject acQuery, "tqry_SubReport" If DCount("*", "Table2", "T1ID=" & Me.IdCbo) = 0 Then CurrentDb.CreateQueryDef "tqry_SubReport", qry_0 Else CurrentDb.CreateQueryDef "tqry_SubReport", qry_1 End If Dim stDocName As String stDocName = "Report1" DoCmd.OpenReport stDocName, acViewPreview, , "[ID]=" & Me.IdCbo Exit_VeiwReportBtn_Click: Exit Sub Err_VeiwReportBtn_Click: If Err.Number = 7874 Then 'query tqry_SubReport does not exist, ignore Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If Resume Exit_VeiwReportBtn_Click End Sub جعفر 1523.ShowReportInNoDate.accdb.zip

طبعا أنا كنت أجرب قبل ما أشوف مشاركة أستاذنا العزيز جعفر 🙂 وهذي محاولتي : طبعا يتم استعراض ملفات ال PDF في المتصفح ( وهذا يتطلب وجود برنامج مشغل PDF ) ويمكن الاستغناء عن العرض الكود يجلب كل الملفات المرتبطة بالرقم المطلوب تلقائيا عند الإنتقال من سجل لآخر في النموذج الفرعي ويجمعها في ليست بوكس .. النقر المزدوج على اسم الملف يفتحه لك خارجيا .. وهذا الكود : Public Sub BringAllFilesAndFolders() Dim path As String, currentPath As String Dim List As ListBox Set List = Forms!tabl1!FileList path = CurrentProject.path & "\Datapdfx\" currentPath = Dir(path, vbDirectory) List.RowSource = "" Do Until currentPath = vbNullString If InStr(currentPath, CStr(Me.noid)) > 0 Then List.AddItem currentPath End If currentPath = Dir() Loop Set List = Nothing End Sub ربط البيانات مع ملف pdf.rar

وعليكم السلام 🙂 تفضل: . وهذا يحدث بهذا الكود: Private Sub Form_Current() Dim rst As DAO.Recordset Dim strFile As String Set rst = Me.tabl2.Form.RecordsetClone rst.MoveFirst Me.lst_Files.RowSource = "" Do Until rst.EOF Debug.Print rst!noid Me.lst_Files.AddItem ">" & rst!noid 'Now lets find how many files we have strFile = Dir(Application.CurrentProject.Path & "\Datapdfx\*" & rst!noid & "*.pdf") Do Until strFile = "" Debug.Print strFile Me.lst_Files.AddItem strFile strFile = Dir() Loop Me.lst_Files.AddItem "" rst.MoveNext Loop End Sub Private Sub lst_Files_DblClick(Cancel As Integer) Dim pdfPath As String If Left(Me.lst_Files, 1) = ">" Then Exit Sub pdfPath = CurrentProject.Path & "\Datapdfx\" & Me.lst_Files Shell "explorer.exe " & pdfPath, vbNormalFocus End Sub جعفر dataPdf.zip

وعليكم السلام ورحمة الله وبركاته .. تفضل أخي العزيز 🙂 Sub CopyFile() 'Requires reference: :لابد من التأكد من وجود المكتبة الاتية 'Add this reference >>---> Microsoft Scripting Runtime Dim fs Set fs = CreateObject("Scripting.FileSystemObject") Dim sPathDeskTop As String Dim oWSH As Object Set oWSH = CreateObject("WScript.Shell") sPathDeskTop = oWSH.SpecialFolders("Desktop") & "\b\" ' هنا اسم المجلد الذي سيتم انشاؤه في سطح المكتب Dim CopyFrom As String, CopyTo As String CopyFrom = Me.a ' هذا اسم الحقل الذي به رابط الملف المراد نسخه CopyTo = sPathDeskTop & Dir(CopyFrom) If Len(Dir(sPathDeskTop, vbDirectory)) = 0 Then MkDir (sPathDeskTop) If Len(Dir(CopyTo, vbDirectory)) = 0 Then fs.CopyFile CopyFrom, CopyTo, True Else MsgBox "هذا الملف موجود مسبقا على سطح المكتب", vbOKOnly Exit Sub End If Set fs = Nothing Set oWSH = Nothing End Sub فقط انتبه للملاحظات المكتوبة في الكود ..

فاجأتوني ، شكرا لكم على الثقة والترقية ، وشكرا لكم جميعا على التهنئة ، وإن شاء الله أكون عند حسن ظنكم دائما.

الكود يعمل فقط على مربع النص الخاص بالتخصص انظر الصورة في الرد السابق لي ..... عموما تفضل ملفك بعد التعديل عليه ........ Database1601.accdb

السلام عليكم و رحمة الله جرب هذا الكود Sub ConTxtNum() Dim ws As Worksheet, C As Range Dim i As Long, j As Long Dim Arr, Tmp, Txt As String Set ws = Sheets("Sheet1") Application.ScreenUpdating = False For Each C In ws.Range("K6:K" & ws.Range("K" & Rows.Count).End(3).Row) For i = 1 To Len(C) Txt = Mid(C, i, 1) If Txt Like "[0-9]" Or Txt = "0" Then Arr = Arr & Txt Else Arr = Arr & " " End If Next Arr = Application.WorksheetFunction.Trim(Arr) Tmp = Split(Arr, " ") For j = 0 To UBound(Tmp) C.Offset(0, j + 2) = Tmp(j) Arr = "" Next Next Application.ScreenUpdating = True End Sub

وعليكم السلام ..قم أولاً بتحويل تنسيق الأرقام إلى رقم لأنها منسقة على شكل نص من V9:V15 أو اضرب قيمة كل خلية بـ 1 أما القيم الرقمية في العمود .AC9:AE15 استبدل كلمة دائن بفراغ وحوله إلى رقم ..أو استخدم المعادلة التالية: =SUBSTITUTE(AC9;"دائن";"") نموذج اوفيسنا.xlsx

تفضل اخي المشكلة في تنسيق الخلايا ليس اكثر تم تعديل الملف اطفال_MH-3.xlsm

السلام عليكم ورحمة الله تعالى وبركاته نعم اخي الفاضل اتضحت الفكرة وللعلم اخي الفاضل استوعاب الفكرة وفهم المطلوب يمثل 90 في المئة من الحل .وهدا ما يجعلني لا اخوض في كثير من المداخلات بسبب عدم شرح السائل لطلبه جيدا او وضع نمودج للنتائج المتوقعة . على العموم اتمنى ان اكون قد استوعبت طلبك اخي الكريم 😁 اليك كودين ولك الاختيار هدا كود لنقل البيانات من الاعمدة الى الصفوف حسب الرمز المكرر من شيت اطفال الى شيت اخر (DATA ) Sub Transpose_to_columns() Dim inp_arr, i As Long, out_arr, dict As Object, key As String Set dict = CreateObject("Scripting.Dictionary") With Sheets("اطفال") inp_arr = .Range(.Cells(2, 5), .Cells(.Rows.Count, 1).End(xlUp)).Value End With For i = 1 To UBound(inp_arr) key = CStr(inp_arr(i, 1)) If dict.Exists(key) Then dict(key) = dict(key) & ";" & inp_arr(i, 3) & ";" & inp_arr(i, 4) & ";" & inp_arr(i, 5) Else dict.Add key, inp_arr(i, 3) & ";" & inp_arr(i, 4) & ";" & inp_arr(i, 5) End If Next i ReDim out_arr(1 To dict.Count, 1 To 4) For i = 0 To dict.Count - 1 out_arr(i + 1, 1) = dict.Keys()(i) out_arr(i + 1, 2) = dict.Items()(i) Next i With Sheets("data") .Cells(2, 1).Resize(dict.Count, 2) = out_arr .Cells(2, 2).Resize(dict.Count, 1).TextToColumns Destination:=.Cells(2, 2), DataType:=xlDelimited, Semicolon:=True End With Set dict = Nothing Sheets("data").Activate End Sub وهدا كود لنقل البيانات من الاعمدة الى الصفوف حسب الرمز المكرر في نفس الشيت (اطفال) Sub MH_transpose_colmns() Dim der, t, ref, nbr&, i&, i1&, i2& Application.ScreenUpdating = False With ActiveSheet If .FilterMode Then .ShowAllData der = Cells(Rows.Count, "a").End(xlUp).Row Columns("a:e").Resize(der).Sort key1:=Range("a1"), order1:=xlAscending, _ key2:=Range("b1"), order2:=xlAscending, Header:=xlYes t = Columns("a:e").Resize(der + 1).Value2 ReDim r(1 To 1, 1 To Columns.Count - Range("h1").Column - 1) Range(Range("h1"), Cells(Rows.Count, Columns.Count)).Clear ref = t(2, 1): i1 = 2: i2 = i1: nbr = 1: r(1, nbr) = ref Do If t(i2, 1) = ref Then nbr = nbr + 1: r(1, nbr) = t(i2, 3) nbr = nbr + 1: r(1, nbr) = t(i2, 4) nbr = nbr + 1: r(1, nbr) = t(i2, 5) i2 = i2 + 1 Else Cells(Rows.Count, "h").End(xlUp).Offset(1).Resize(, nbr) = r ReDim r(1 To 1, 1 To Columns.Count - Range("h2").Column - 1) i1 = i2: i2 = i1: ref = t(i2, 1): nbr = 1: r(1, nbr) = ref If ref = "" Then Exit Do End If Loop End With Application.ScreenUpdating = True End Sub واليك الملف مع اضافة الاكواد ....في حالة الرغبة في الاضافة او التعديل لا تتردد اخي الكريم.بالتوفيق ... اطفال_MH.xlsm

وعليكم السلام-تفضل لك ما طلبت trait office1.xlsm

جزاك الله خسر الثواب وأكرمك الله وأحسن الله اليك

أحسنت أستاذنا الكريم وبارك الله فيك .. طبعاً موضوع مهم وقيم , جعله الله فى ميزان حسناتك

تفضل اخي test_gold.xlsx

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

وعليكم السلام ..بما انك لم تقم برفع ملف ,,فكان عليك استخدام خاصية البحث بالمنتدى فطلبك تكرر كثير جداً وشوف بنفسك : وده كمان مثال بملف مرفق لك وكلمة السر لإظهار الصفحات : 123 اخفاء الشيتات و ترك الشيت الرئيسي هو الظاهر كود اخفاء الشيتات عدا شيت محدد اخفاء الصفحات تلقائيا اخفاء أوراق العمل وعدم اظهارها فورم_كود اظهار و اخفاء للصفحات Sheets Hidding - 2.xlsm

وعليكم السلام أهلاً بك فى المنتدى -تفضل لك ما طلبت ويجب عليك اتباع الخطوات كما بالصورة حدود الصفحة.xlsm

يمكنك استخدام هذه المعادلة لطلبك ..معادلة مصفوفة (Ctrl+Shift+Enter) =IFERROR(INDEX(Table2[التاريخ],SMALL(IF(Table2[اسم الموقع/ المخزن]=$C$3,ROW($A$4:$A$11)-ROW($A$4)+1),ROWS(A$1:A1))),"") كشف حساب مشروع1.xlsx

وكذلك كود اخوي موسى بطريقتي : If Len(Me.nox & "") = 0 Then Exit Sub جعفر

فقط يمكنك استخدام هذه المعادلة أو بعمل تنسيق للخلايا بأن يكون تنسيق الخلية يوم وليس تاريخ B2dddd =TEXT(B3,"b2dddd") هاجر البصمة1.xlsx

السلام عليكم قبل البدء انت محتاج تغير ال listbox اللى قدام الكود الى combobox وليكن combobox2 اولا انت محتاج تملا الكمبو بوكس مع بداية عمل الفورم Private Sub UserForm_Initialize() Dim LR As Long With Sheets("update 2022 September") LR = .Range("A" & .Rows.Count).End(xlUp).Row Me.ComboBox2.RowSource = "=$A$4:$A$" & LR Me.ComboBox1.RowSource = "=$C$4:$C$" & LR End With End Sub كده انت ملأت الاتنين الكمبوبوكس يبقى انت محتاج كود عند تغيير الكمبوبوكس Private Sub ComboBox2_Change() ComboBox1.ListIndex = ComboBox2.ListIndex If ComboBox2.ListIndex <> -1 Then TextBox3.ControlSource = "=$H$" & ComboBox2.ListIndex + 4 Else TextBox3.ControlSource = "" TextBox3.Text = "" End If End Sub وبكده التكست بوكس اصبحت مرتبطه بالخليه يعنى اي تغيير فيها ها يتحدث اتوماتيتك فى الخليه * الجمله الشرطية للتأكد انك كتبت كود موجود داخل الليست , , والا يلغى ارتباط التكست بوكس بالخلية ثم يمسح محتوى التكست بوكس * ال 4 دي بداية اول سطر بيانات فى الجدول

تفضل التعديل أخي m.r 🙂 Sub CopyFile() Dim sPathDeskTop As String sPathDeskTop = Environ("USERPROFILE") & "\Desktop" & "\b\" ' هنا اسم المجلد الذي سيتم انشاؤه في سطح المكتب Dim CopyFrom As String, CopyTo As String CopyFrom = Me.SourceFilePath ' هنا تضع اسم الحقل الذي به رابط الملف المراد نسخه CopyTo = sPathDeskTop & Me.NewFileName & ".pdf" ' هنا تضع اسم الحقل الذي به اسم الملف الجديد وامتداده If Len(Dir(sPathDeskTop, vbDirectory)) = 0 Then MkDir (sPathDeskTop) If Len(Dir(CopyTo, vbDirectory)) = 0 Then FileCopy CopyFrom, CopyTo Else MsgBox "هذا الملف موجود مسبقا", vbOKOnly Exit Sub End If End Sub

لا اتفق معك استاذنا العزيز طاهر مثلا الان نحن في شهر 9 ميلادي 2 هجري لو حولت التاريخ وفقا لما صنعت سيكون الميلادي 2022 والهجري 1444 وهذا تمام جزئيا لكون الاشهر الستة الاولى من شهر 2022 توافق العام 1443 بعد اربعة اشهر يكون الميلادي 2023 والهجري وفقا لعملك 1445 وهذا غير صحيح لكوننا مازلنا في الشهر السادس 1444 ايضا جزء من عام 2024 سيكون ضمن العام الهجري 1445 والعام 1446 وعام 2025 سيكون ضمن العام 1446 والعام 1447 هجري ايضا العام 2030 بحسابك سيكون 1453 بينما يفترض ان يكون 1451 والعام 1452 اعتقد ان العمل يحتاج الى اعادة النطر والتحويل بالسنة بدون اليوم والشهر لن يعطي النتيجة المطلوبة رأي شخصي غير ملزم

تفضل اخي Sub MH_copy() Dim i As Long Application.ScreenUpdating = False With Cells(1).CurrentRegion For i = 2 To .Rows.Count Step 6 lastro = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row + 1 .Rows(i).Resize(6).Copy Range("c" & Rows.Count).End(xlUp)(2).PasteSpecial Transpose:=True Next End With If Range("c3").Value <> "" Then Range("C2:h" & lastro).Select With Range("C2:h" & lastro).Borders.LineStyle = xlNone Range("C2:h" & lastro).Borders.LineStyle = xlContinuous Range("a1").Select Application.ScreenUpdating = True End With End Sub 1.xlsm

بارك الله فيك وزادك الله من فضله

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

طيب ادخل على تفصيل النموذج ..... حدث عند الطباعة وادرج الكود التالي .... Dim ctl As Control, strText As Variant, strName As String Me.ScaleMode = 1 For Each ctl In Me.Detail.Controls If ctl.ControlType = acTextBox And ctl.name = "Text4" Then strName = ctl.name If Nz(ctl.Tag, "") = "" Then ctl.Tag = ctl.FontSize End If ctl.FontSize = ctl.Tag Me.FontSize = ctl.FontSize strText = ctl.Value If Len(strText) > 0 Then Do Until TextWidth(strText) < ctl.Width ctl.FontSize = ctl.FontSize - 1 Me.FontSize = ctl.FontSize Loop Do Until TextHeight(strText) < ctl.Height - (ctl.Height * 0.26) ctl.FontSize = ctl.FontSize - 1 Me.FontSize = ctl.FontSize Loop End If End If Next ctl ثم انظر النتيجة ......................

tb10 قيمه الفاتورة AAAAA(1).xlsm

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

لديك الآن 4 خيارات عن طريق الأزرار/الضغطات في صفحة المسودة ..موفقين. كود توزيع القرار_12.xlsm

هنا الاستاذ العزيز احمد قام بتعديل نوع الحقل الى نص والامور تمام طيب لو اردنا بقاء الحقل كماهو تاريخ وقت واظهار اليوم Me.Zday = [Zdate] ثم في خصائص الحقل zday تنسيق نضع dddd الملف مرفق تاريخ.accdb

وعليكم السلام ورحمه الله وبركاته اتفضل تم تعديل حقل zday فالجدول لنص ليقبل اسم اليوم Me.Zday = Format(Me.Zdate, "dddd") بالتوفيق تاريخ.accdb

السلام عليكم ورحمة الله اخى الكريم الكود يقوم بمسح البيانات حتى الصف رقم 49 ..سيتم رفع الملف بعد التعديلات لصعوبة تطبيقها بنفسك قوائم.xlsm

يمكنك ذلك بهذه المعادلة =INDEX($C$17:$R$24,MATCH($F$5,$B$17:$B$24,0),MATCH($J$5,$C$15:$R$15,0)) 1اسعار العملات.xlsx

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

السلام عليكم و رحمة الله اجعل الكود هكذا Sub y() Dim sumRange As Range, criteriaRange As Range Dim result As Double Dim i As Integer Dim lastrow As Long Dim R As Range Dim criteria As Variant Set criteriaRange = Range("D4:D20") criteria = Array("اجمالي صنف1", "اجمالي صنف2") j = 1 Do While j <= 6 Set sumRange = Range("E4:E20").Offset(0, j - 1) For i = 0 To UBound(criteria) result = WorksheetFunction.Sum(result, WorksheetFunction.SumIfs(sumRange, criteriaRange, criteria(i))) Set R = ActiveSheet.Cells.Find("اجمالي الأصناف", , xlValues, xlWhole) If Not R Is Nothing Then R.Select ActiveCell.Offset(0, j).Select ActiveCell.Value = result Next i result = 0 j = j + 1 Loop Range("D3").Activate End Sub

تفضل اخي تم تعديل الملف ليتناسب مع طلبك مع بعض الاضافات البسيطة اتمنى ان تلبي المطلوب بادن الله Sub Copie_Sheets_Numérotée_MH() Dim Ind As Integer Dim FlgExist As Boolean, Test As String Application.ScreenUpdating = False Sheet3.Copy After:=Sheets(Sheets.Count) Ind = 2 Do On Error Resume Next Test = Sheets("hakan" & Ind).Range("A1").Value If Err.Number = 0 Then FlgExist = True: Ind = Ind + 1 Else FlgExist = False Loop While FlgExist On Error GoTo 0 ActiveSheet.Name = "hakan" & Ind Sheet2.Select Application.Calculation = xlAutomatic Application.ScreenUpdating = True End Sub mango_MH3.xlsm

حياك الله أخي حامل المسك 🙂 ضع هذا السطر في أول الكود .. If IsNull(Me.nox) Or Me.nox = "" Then Exit Sub

الحمد لله،، ثم الحمد لله.. المبدعون الكرام.. @jjafferr @Moosak تقف الكلمات حائرة.. أمام جميل تعاونكم البناء وأخوتكم الكريمة.. تلاقت الأرواح بكل جمال ومحبة وصدق وتعاون.. فلكم منا صادق الدعاء فلقد أجدتم ونفعتم وكفيتم ووفيتم.. والحمد لله ضبطت الطريقة.. فشكر الله شكرا عظيما وجزاكم خير الجزاء وبارك لكم فيما رزقكم وجعل ما جدتم به رفعة لكم في الدنيا والآخرة..

وعليكم السلام 🙂 اجعل اسم الزر cmd_clear_fields ، ثم ضع الكود في حدث النقر على الزر: Private Sub cmd_clear_fields_Click() On Error GoTo err_cmd_clear_fields_Click Dim ctl As Control For Each ctl In Me.Controls If ctl.ControlType = acTextBox Or ctl.ControlType = acComboBox Then If ctl.Name <> "g1s11" And _ ctl.Name <> "g1s12" And _ ctl.Name <> "g1s13" And _ ctl.Name <> "g1s14" And _ ctl.Name <> "g1s15" Then ctl.Value = "" End If End If Next Exit_cmd_clear_fields_Click: Exit Sub err_cmd_clear_fields_Click: If Err.Number = 2448 Then 'can't change autonumber Resume Next ElseIf Err.Number = 3314 And ctl.Name = "g1s3" Then 'a date must be entered ctl.Value = Date Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If Resume Exit_cmd_clear_fields_Click End Sub جعفر up.zip

كان عليك استخدام خاصية البحث بالمنتدى قبل طرح مشاركتك فبه طلبك -تفضل https://www.officena.net/ib/search/?&q=تفقيط مساحة&search_and_or=and&sortby=relevancy

شكرا اخوي موسى 🙂 وهذا رابط أخر ، فيه شرح يخص الاستعلام : جعفر

ألف مبروك على التهنئة وبالتوفيق والنجاح دائماً

اخوانى الكرام الملف يعمل عندى وهذه صورة الواجهة وسأرسل الملف مرة اخرى برنامج اجازات الموظفين.xlsm

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