عبدالله بشير عبدالله

في طلبك الاول TextBox8 فقط والان تغير الطلب الى الكمبوبكس يمكن اظافة التالي الى UserForm_Initialize Dim ctrl As Control For Each ctrl In Me.Controls If TypeName(ctrl) = "ComboBox" Then ctrl.Style = fmStyleDropDownList ctrl.Locked = False End If Next ctrl برنامج المراكز الطبية 30 اغسطس.xlsm

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

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

وعليكم السلام ورحمة اللع وبركاته لم تصلنى الفكرة بعد اين توجد القائمة المتسدلة لا اعتفد انها في TextBox8 لان TextBox في الـ VBA (UserForm) لا يدعم قائمة منسدلة (DropDown / List) ، مع وجود ComboBox. انا اذا كانت TextBox8 مرتبطة بكمبوبكس او لستبكس - قم بالضغط على TextBox8 في وضع التصميم ثم من الخصائص على يسار الشاشة اختار locked - true او enabled-false ارفاق ملف يختصر الوقت لفهم فكرة عمل TextBox8 تحياتي

السلام عليكم اليك الملف المرشحين1.xlsb

جزاك الله خيرا استاذنا الفاضل

جربت الملف لا توجد اي مشكلة الكود يعمل جيدا , اذا كان pdf مفتوحا تخدت هذه المشكلة او اذا كان اسم العميل يحتوى على اي من الحروف الاتية تخدث المشكلة \ / : * ? " < > | جرب على جهاز احر وتامل من الاعضاء التجربة لنتاكد

السلام عليكم ورحمة الله وبركاته تم استبدال التكستبوكس بكمبوبكس فبدل كتابة الاسم تجد الاسماء جاهزة في فائمة البيانات ستحتوى تلقائيًا بعرض الصفحة اثناء الطباعة بعد الإنشاء، يظهر مربع حوار 3 خيارات: نعم = طباعة مباشرة لا = حفظ كـ PDF إلغاء = معاينة قبل الطباعة خفظ pdf باسم العميل الملف متابعة (1).xlsm

وضحت الفكرة استاذنا ايشر خيرا ان شاء الله

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

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

وعليكم السلام ورحمة الله وبركاته جرب هذا التعديل مخزن3 (1).xlsm

السلام عليكم ورحمة الله وبركاته الكود Sub CheckAbsence() Dim ws As Worksheet Dim lastRow As Long, i As Long, j As Long Dim countConsecutive As Long, maxConsecutive As Long Dim countTotal As Long Dim msg As String Dim cell As Range Set ws = ThisWorkbook.Sheets("ورقة1") lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row For i = 2 To lastRow countConsecutive = 0 maxConsecutive = 0 countTotal = 0 ' المرور على نطاق الغياب C:AG For Each cell In ws.Range("C" & i & ":AG" & i) If cell.Value = "غ" Then countConsecutive = countConsecutive + 1 countTotal = countTotal + 1 If countConsecutive > maxConsecutive Then maxConsecutive = countConsecutive End If Else countConsecutive = 0 End If Next cell msg = "" If maxConsecutive >= 15 Then msg = "مفصول" ElseIf maxConsecutive >= 5 Then msg = "إنذار أول" End If If countTotal >= 30 Then msg = "مفصول" ElseIf countTotal >= 24 Then msg = "إنذار ثالث" ElseIf countTotal >= 16 Then msg = "إنذار ثاني" ElseIf countTotal >= 8 And msg = "" Then msg = "إنذار أول" End If ws.Cells(i, "AH").Value = msg Next i End Sub الملف سجل غياب الطلاب1.xlsb

السلام عليكم كود طباعة وكود تحويل pdf Sub Print_Managers_Deputies() Dim wsData As Worksheet, wsReport As Worksheet Dim lastRow As Long, i As Long Dim idVal As String, roleVal As String Application.ScreenUpdating = False Application.EnableEvents = False Set wsData = ThisWorkbook.Sheets("data") Set wsReport = ThisWorkbook.Sheets("التقرير مدير وكيل") lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row For i = 3 To lastRow idVal = wsData.Cells(i, "A").Value roleVal = wsData.Cells(i, "E").Value If (InStr(1, roleVal, "مدير", vbTextCompare) > 0) _ Or (InStr(1, roleVal, "وكيل", vbTextCompare) > 0) Then wsReport.Range("L2").Value = idVal wsReport.PrintOut wsReport.Range("L2").Value = 1 End If Next i MsgBox "تمت طباعة جميع المديرين والوكلاء.", vbInformation Application.ScreenUpdating = True Application.EnableEvents = True End Sub Sub sav_PDFall2() Dim wsData As Worksheet, wsReport As Worksheet Dim lastRow As Long, i As Long Dim roleVal As String Dim folderPath As String, pdfPath As String Dim safeName As String Application.ScreenUpdating = False Application.EnableEvents = False Set wsData = ThisWorkbook.Sheets("data") Set wsReport = ThisWorkbook.Sheets("التقرير مدير وكيل") wsReport.Unprotect password:="0" folderPath = ThisWorkbook.Path & "\التقرير مدير وكيل" If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row For i = 3 To lastRow roleVal = wsData.Cells(i, "E").Value If (InStr(1, roleVal, "مدير", vbTextCompare) > 0) _ Or (InStr(1, roleVal, "وكيل", vbTextCompare) > 0) Then wsReport.Range("C9").Value = wsData.Cells(i, "B").Value safeName = wsReport.Range("C9").Value safeName = Replace(safeName, "/", "-") safeName = Replace(safeName, "\", "-") safeName = Replace(safeName, ":", "-") safeName = Replace(safeName, "*", "-") safeName = Replace(safeName, "?", "-") safeName = Replace(safeName, """", "-") safeName = Replace(safeName, "<", "-") safeName = Replace(safeName, ">", "-") safeName = Replace(safeName, "|", "-") pdfPath = folderPath & "\" & safeName & ".pdf" wsReport.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=pdfPath, _ Quality:=xlQualityMinimum, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False End If Next i MsgBox "تم حفظ جميع ملفات PDF للمديرين والوكلاء في:" & vbCrLf & folderPath, vbInformation wsReport.Protect password:="0" Application.ScreenUpdating = True Application.EnableEvents = True End Sub الملف طباعة وظائف محددة.xlsm

وعليكم السلام ورخمة الله وبركاته ربما تفصد اخفاء الاعمدة وليس الخذف كما ورد في طلبك الكود يخفى العمود كله فارغ أو كله قيمه تساوي (0 أو 0%) → يخفي العمود بالكامل. الكود في البداية يظهر كل الأعمدة ثم يعيد إخفاء المناسب تم ربط الكود مع امر الفلترة اظافة التسطير لناتج الفلترة هذا خسب فهمى لطلبكم الكود Sub فلترة_اخفاء() Dim wsSrc As Worksheet, wsDst As Worksheet Dim lastRow As Long Dim rng As Range, col As Range, c As Range Dim hideCol As Boolean Dim rngOut As Range Application.ScreenUpdating = False Set wsSrc = ThisWorkbook.Sheets("المجمع") Set wsDst = ThisWorkbook.Sheets("1") lastRow = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Row If lastRow >= 5 Then wsDst.Rows("5:" & lastRow).ClearContents wsDst.Rows("5:" & lastRow).ClearFormats End If wsDst.Columns("A:W").Hidden = False lastRow = wsSrc.Cells(wsSrc.Rows.Count, "E").End(xlUp).Row If lastRow < 2 Then Exit Sub wsSrc.Range("E1:W" & lastRow).AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=wsDst.Range("Criteria"), _ CopyToRange:=wsDst.Range("Extract"), _ Unique:=False lastRow = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then GoTo Done Set rngOut = wsDst.Range("A5:W" & lastRow) With rngOut.Borders .LineStyle = xlContinuous .Color = vbBlack .Weight = xlThin End With rngOut.EntireColumn.Hidden = False For Each col In rngOut.Columns hideCol = True For Each c In col.Cells If Not (isEmpty(c.Value) Or c.Value = 0 Or c.Text = "0%") Then hideCol = False Exit For End If Next c If hideCol Then col.EntireColumn.Hidden = True Next col Done: Application.ScreenUpdating = True End Sub الملف W1.xlsm تحياتي

وعليكم السلام ورحمة الله وبركاته تم انشاء كود الطباعة والمعاينة اتمنى ان تجد في الحل طلبك لك وافر الاحترام Sub Print_All_Employees() Dim ws As Worksheet Dim cell As Range Dim rng As Range Set ws = ThisWorkbook.Sheets("إداريين") Set rng = ws.Range("C3:C137") Application.ScreenUpdating = False For Each cell In rng If cell.Value <> "" Then ws.Range("CQ6").Value = cell.Value ws.PageSetup.PrintArea = "CP5:CY47" ws.PrintOut End If Next cell ws.Range("CQ6").Value = rng.Cells(1, 1).Value Application.ScreenUpdating = True MsgBox "تمت طباعة جميع الموظفين بنجاح.", vbInformation End Sub طباعة الكل بضغطة.xlsm

وفيك بارك الله تم التعديل Private Sub ComboBox1_Change() On Error Resume Next Application.EnableEvents = False Sheets("Sheet2").Range("L8").value = ComboBox1.value TextBox12.value = Sheets("Sheet2").Range("L10").value Application.EnableEvents = True On Error GoTo 0 End Sub Private Sub TextBox12_Change() Static lastValue As Variant On Error Resume Next Application.EnableEvents = False If IsNumeric(Me.TextBox12.value) Then Dim value As Integer value = CInt(Me.TextBox12.value) Dim minValue As Integer, maxValue As Integer, newValue As Integer If value >= 8 Then minValue = 0 maxValue = 40 Else minValue = 0 maxValue = 30 End If Randomize Do newValue = Int((maxValue - minValue + 1) * Rnd()) + minValue Loop While newValue = lastValue Me.TextBox3.value = newValue lastValue = newValue ThisWorkbook.Sheets("Sheet2").Range("L13").value = newValue End If Application.EnableEvents = True On Error GoTo 0 End Sub if أوفيسنا 3.xlsb

الاجابة في المشاركة التالية

كود الذي قدمه استاذنا حسونة حسين كافٍ وأسرع ، لأنه: يمرّ على النطاق مرة واحدة فقط لتحديد الصفوف التي يجب إخفاؤها. يستخدم Union لتجميع الصفوف وإخفائها دفعة واحدة بدل إخفاء كل صف على حدة. يعيد أولًا إظهار جميع الصفوف ثم تخفي فقط الصفوف التي فيها صفر. بالنسبة للارقام العشرية هذا ملفك وهذا التنسيق كما قدمته انت وان كان لديك نتسيق معين ارجو توضيحه

وعليكم السلام ورحمة الله وبركاته يمكنك استخدام المعادلة نم اسخبها للاسفل =TEXT(D7;"dd/mm/yyyy") تحويل التاريخ الى نص.xlsx

السلام عليكم حسب فهمى لطلبك اليك الكود / اكتب القيمة في G2 Private Sub Worksheet_Calculate() Dim cell As Range Application.EnableEvents = False For Each cell In Me.Range("E6:E12") If cell.Value = 0 Then cell.EntireRow.Hidden = True Else cell.EntireRow.Hidden = False End If Next cell Application.EnableEvents = True End Sub 11.xlsb

وعليكم السلام ورخمة الله وبركاته جرب هذا الكود Sub MergeSheets_Total() Dim ws As Worksheet, wsTotal As Worksheet Dim i As Long, destRow As Long Dim dateValue As Variant Dim r As Long, lastDataRow As Long Dim sheetName As String On Error Resume Next Set wsTotal = ThisWorkbook.Sheets("TOTAL") On Error GoTo 0 If wsTotal Is Nothing Then MsgBox "لم يتم العثور على الشيت TOTAL", vbCritical Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False wsTotal.Range("A3:F320").ClearContents destRow = 3 For i = 1 To 31 sheetName = Format(i, "00") On Error Resume Next Set ws = ThisWorkbook.Sheets(sheetName) On Error GoTo 0 If Not ws Is Nothing Then lastDataRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row If lastDataRow >= 4 Then dateValue = ws.Range("B1").Value For r = 4 To lastDataRow If Trim(ws.Cells(r, "A").Value) <> "" Then wsTotal.Cells(destRow, "B").Resize(1, 5).Value = ws.Cells(r, "A").Resize(1, 5).Value wsTotal.Cells(destRow, "A").Value = dateValue destRow = destRow + 1 End If Next r End If End If Set ws = Nothing Next i Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub The Safe1.xlsb

وعليكم السلام ورحمة الله وبركاته الكود يرتب حسب العمود H اولا ث ثم يرتب حسب العمود C Sub SortByColumn() Dim ws As Worksheet Dim rng As Range Dim lastRow As Long Set ws = ActiveSheet lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row Set rng = ws.Range("A3:S" & lastRow) With ws.Sort .SortFields.Clear .SortFields.Add Key:=rng.Columns(8), Order:=xlAscending .SortFields.Add Key:=rng.Columns(3), Order:=xlAscending .SetRange rng .Header = xlNo .Apply End With End Sub اتمنى ان تجد فيه طلبك

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

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