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

إليك أخي الملف كما طلبت مع تلوين الخلايا حسب الاختيار تسجيل بيانات2.xlsm

السلام عليكم ورحمه الله وبركاته ممكن تسنخدم الكود التالي قد يفي بالغرض Function MyFilter(LookInRange As Range, CriteriaRange As Range, CriteriaValue As Variant) As Variant Dim cell As Range Dim results() As Variant Dim count As Long Dim i As Long ReDim results(1 To CriteriaRange.Rows.Count, 1 To 1) count = 0 For i = 1 To CriteriaRange.Rows.Count If CriteriaRange.Cells(i, 1).Value = CriteriaValue Then count = count + 1 results(count, 1) = LookInRange.Cells(i, 1).Value End If Next i If count = 0 Then MyFilter = CVErr(xlErrNA) Else ReDim Preserve results(1 To count, 1 To 1) MyFilter = results End If End Function =MyFilter(A2:A10, B2:B10, "الرياض") A2:A10 العمود الذي تريد إرجاع القيم منه (مثل الأسماء) B2:B10 العمود الذي يحتوي على الشرط (مثل المدينة) "الرياض" القيمة التي يتم التصفية بناءً عليها

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك تعديل هدا بما يناسبك Option Explicit Sub Sauvegarde_WB() Dim WS As Worksheet, CrWS As Workbook, newWs As Worksheet, f As Worksheet Dim chemin$, sNom$, dossier$, sPath$, n As Boolean On Error GoTo EndClear SetApp False Set CrWS = Workbooks.Add(xlWBATWorksheet) Set f = CrWS.Sheets(1): f.Name = "Temp" n = True For Each WS In ThisWorkbook.Worksheets WS.Copy After:=CrWS.Sheets(CrWS.Sheets.Count) Set newWs = CrWS.Sheets(CrWS.Sheets.Count) newWs.UsedRange.Value = newWs.UsedRange.Value On Error Resume Next: newWs.Buttons(1).Delete: On Error GoTo 0 newWs.Name = Left(WS.Name, 31) If n Then: f.Delete: n = False Next WS dossier = ThisWorkbook.Path & "\Workbook_Copy" If Dir(dossier, vbDirectory) = "" Then MkDir dossier sPath = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) sNom = sPath & "_" & Format(Now, "dd-mm-yyyy") & ".xlsx" chemin = dossier & "\" & sNom CrWS.SaveAs Filename:=chemin, FileFormat:=xlOpenXMLWorkbook CrWS.Close False SetApp True Exit Sub EndClear: SetApp True End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub TEST.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد معاينة آخر مشاركاتك على المنتدى إليك الكود ليتوافق مع جميع الإصدارات سواءا 32bit أو 64bit جرب هدا ربما يناسبك Option Explicit #If VBA7 Then Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long #Else Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long #End If Private Const Style As Long = -16 Private Const Menu As Long = &H80000 Private Const MIN As Long = &H20000 Private Const MAX As Long = &H10000 Private Sub UserForm_Activate() Dim xForm As LongPtr, tmps As Long xForm = FindWindow("ThunderDFrame", Me.Caption) If xForm <> 0 Then tmps = GetWindowLong(xForm, Style) tmps = tmps Or Menu Or MIN Or MAX SetWindowLong xForm, Style, tmps DrawMenuBar xForm End If End Sub TEST Minimize.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Public Property Get WS() As Worksheet: Set WS = Sheets("الاختلافات"): End Property Sub Button1_Click() Dim i As Long SetApp False For i = 3 To 62 WS.Rows(i).Hidden = (Application.WorksheetFunction.CountA(WS.Range("B" & i & ":R" & i)) = 0) Next i SetApp True End Sub Sub Button49_Click(): SetApp False: WS.Rows("3:62").Hidden = False: SetApp True: End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With On Error GoTo 0 End Sub كود إخفاء وإظهار.xlsb

و عليكم السلام ورحمة الله و بركاته ممكن مشاهده الروابط ادناه لعله يفيدك ويفي بالغرض

أخي الكريم أرفق ملف و وضح الطلب قدر الإمكان =NOW()+0.25 بالنسبة للمعادلة فهي تُستخدم لإضافة ربع يوم (6 ساعات) إلى التاريخ والوقت الحاليين

رائع

لا يمكنك "إضافة" دالة FILTER الحديثة إلى Excel 2007. يمكنك استخدام "التصفية التلقائية" و "التصفية المتقدمة" المدمجة في Excel 2007. يمكن استخدام طرق أكثر تعقيدًا باستخدام صيغ المصفوفات القديمة، لكنها تتطلب معرفة متقدمة وتكون أقل سهولة في الاستخدام مقارنة بدالة FILTER. لذا، أفضل الخيارات المتاحة لك في Excel 2007 هي التصفية التلقائية والتصفية المتقدمة.

نعم ممكن , جرب هذا جدول 3.xlsx

جرب الملف التالي حسب فهمي للموضوع جدول 2.xlsx

عندي ملف من إعداد الاستاذ مصطفى شرف و قمت بالتعديل عليه الشرح للأستاذ مصطفى من هنا توزيع الملاحظين 2024.xlsm

مشاركة بتوضيح فكرة الأستاذ @محمد هشام. مشكوراً على فكرته الجميلة .. 1. انسخ الدالة السابقة الى مديول جديد في مشروعك الرئيسي واحفظه . 2. تستطيع تشغيل الماكرو بالنقر على Alt + F8 ، ثم تختار اسم الماكرو ، وانقر زر تشيل Run . 3. سيتم إنشاء مجلد جديد حسب الكود ( Workbook_Copy ) . وبداخله نسخة من مشروعك الأصلي لا تحتوي معادلات أو أزرار أو أكواد ... الخ . 💡 والتوظيف الذكي في الكود ، أن النسخة الناتجة لا تدعم الماكرو حتى لو حاولت إعادة تضمينها ، انظر السطر :- xlOpenXMLWorkbook ' أي .xlsx أي أنه لم يستخدم فكرة استنساخ الملف الجديد عن الأصل بنفس الإمتداد . ودمتم بخير جميعاً

ملف آخر يشمل سلايسر و معادلات و كود الفلترة2.xlsm

و عليكم السلام ورحمة الله وبركاته الملف مطبق عليه الفلترة باستخدام slicer الفلترة2.xlsx

وإياكم مثلما دعيتم وأكثر في هذا اليوم الطيب .. العفو يا صديقي ..

أخي @algammal بما أننا اعتمدنا على العمل الديناميكي أثناء التعامل مع الملف أود أن أشاركك طريقة أخرى أكثر ديناميكية لإنشاء الأزرار الخاصة بالتنقل بين الأوراق دون الحاجة إلى نسخ الارتباطات من ورقة معاشات يتم إنشاء زر لكل ورقة عمل في المصنف بشكل تلقائي - استثناء الورقة التي يشير إليها الزر أي لا يضاف زر داخل نفس الورقة - تلوين الزر بنفس لون تبويب الورقة التي يشير إليها الزر لسهولة التعرف والتمييز البصري ربط الزر بكود التنقل GotoSheet الموضح أدناه مما يتيح الانتقال بين أوراق العمل المقصودة دون الإعتماد على أي إرتباط تشعبي Sub GotoSheet() SetApp False Dim wsName As String wsName = Replace(Application.Caller, "btn_", "") On Error Resume Next ThisWorkbook.Sheets(wsName).Activate On Error GoTo 0 SetApp True End Sub توحيد البحث في شيت واحد v10.xlsb

و عليكم السلام ورحمة الله و بركاته تحياتي للأستاذ @Foksh الألوان تستخدم في كنترول الابتدائي و ذلك لعدم وجود طابعات ألوان فيتم كنتابة اللون . لذلك هناك حل بسيط بالمعادلات حيث يتم لصق المعادلة التالية في الخلية M7 ثم سحبها للأسفل: =IFS(I9>=85;"أزرق"; I9>=65;"أخضر"; I9>=50;"أصفر"; TRUE;"أحمر")

وعليكم السلام ورحمة الله وبركاته ,, بداية أود أن أوضح لك أنه لا يمكن لأكسل التعرف على اسم اللون كما في طلبك ، ولكن يمكننا التحايل عليه بفكرة إلتفافية حول الموضوع ، حيث أولاً يمكن استخراج رقم ( كود ) اللون ، وبذلك أولاً سنستخدم دالة بسيطة تساعدنا في هذه المهمة كالآتي :- Function GetColorCode(rng As Range) As Long GetColorCode = rng.Interior.Color End Function الآن بعد أن حصلنا على النتيجة ، سنستخدم دالة تقوم بالتعرف على اللون الناتج من الدالة السابقة ومحاولة تقريبه الى أقرب درجة معروفة سنقوم بإدخال قيمها يدوياً داخل الدالة ، كالآتي :- Function GetApproximateColorName(rng As Range) As String Dim colorCode As Long, R As Integer, G As Integer, B As Integer colorCode = rng.Interior.Color R = colorCode Mod 256 G = (colorCode \ 256) Mod 256 B = (colorCode \ 65536) Mod 256 If R > 200 And G < 50 And B < 50 Then GetApproximateColorName = "أحمر" ElseIf R > 200 And G > 200 And B < 100 Then GetApproximateColorName = "أصفر" ElseIf R > G And R > B Then GetApproximateColorName = "أحمر" ElseIf G > R And G > B Then GetApproximateColorName = "أخضر" ElseIf B > R And B > G Then GetApproximateColorName = "أزرق" ElseIf R = G And G = B Then GetApproximateColorName = IIf(R < 128, "غامق", "فاتح") & " رمادي" Else GetApproximateColorName = "لون مختلط" End If End Function طبعاً قمت بتغيير الألوان في مثالك إلى الألوان الصريحة لكل لون ( الأخضر ، الأزرق ، الأصفر ، الأحمر ) . وبهذا ، سيتم الاستدعاء في الخلية التي تريد إدراج اسم اللون فيها بهذا الشكل :- =GetApproximateColorName(K7) طبعاً فقط ضع هذا الكود في الخلية L7 ثم اسحب تحديد الخلية الى باقي الخلايا لتطبيق الكود عليها جميعاً . وهذا ملفك بعد التعديل :- Book2.xlsm

وعليكم السلام ورحمة الله وبركاته ، في البداية أعتقد أن الفكرة قد تكون متشعبة نوعاً ما ، بالإعتماد على النتائج التي قد تحتلف في كل مرة يتم فيها النقر على زر "توزيع الملاحظين" . لذا بعد تجربتك لهذه الفكرة البسيطة ، أخبرنا بالنتيجة وبالتفصيل . مع العلم أنه يوجد لديك فكرتين ، ومن خلال تجربتك ومتابعتك للنتائج ، اخبرنا بتفاصيل النتائج التي عادت لك . شرح الفكرة الأولى التي تمت :- السرعة في التوزيع ، حيث يعمل الكود بشكل أسرع بكثير لأنه :- يستخدم مصفوفات للتعامل مع البيانات بدلاً من الخلايا مباشرة . يعطل التحديث التلقائي وإعادة الحساب أثناء التنفيذ . ضمان عدم تكرار الملاحظ في نفس اللجنة :- يستخدم خوارزمية توزيع دائرية تضمن عدم التكرار في اللجنة الواحدة . التوزيع العادل :- يحاول توزيع الملاحظين على اللجان بالتساوي قدر الإمكان . يمر كل ملاحظ على جميع اللجان خلال فترات الامتحانات . الكود الذي تم استخدامه لهذه الفكرة ( مع دالة بسيطة مساعدة ) :- Sub DistributeObservers() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual On Error GoTo ErrorHandler Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets("الثانوية العامة") Dim observers As Range, committees As Range Dim observerCount As Long, committeeCount As Long Dim distributionRange As Range Dim i As Long, j As Long, attempts As Long Dim observerList() As Variant, committeeList() As Variant Dim distributionArray() As Variant Dim observerUsage() As Long Set observers = ws.Range("B3:B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).row) observerCount = observers.Count observerList = observers.Value committeeCount = 30 ReDim committeeList(1 To committeeCount) For i = 1 To committeeCount committeeList(i) = "لجنة " & i Next i Set distributionRange = ws.Range("D3").Resize(observerCount, committeeCount) ReDim distributionArray(1 To observerCount, 1 To committeeCount) ReDim observerUsage(1 To observerCount) Dim randomizedObservers() As Variant randomizedObservers = ShuffleArray(observerList) For j = 1 To committeeCount For i = 1 To observerCount distributionArray(i, j) = randomizedObservers((i + j - 2) Mod observerCount + 1, 1) observerUsage((i + j - 2) Mod observerCount + 1) = observerUsage((i + j - 2) Mod observerCount + 1) + 1 Next i Next j distributionRange.Value = distributionArray For i = 1 To observerCount ws.Cells(i + 2, 1).Value = Application.CountIf(distributionRange, observerList(i, 1)) Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم التوزيع بنجاح!", vbInformation + vbMsgBoxRight, "" Exit Sub ErrorHandler: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "حدث خطأ: " & Err.Description, vbCritical + vbMsgBoxRight, "" End Sub Function ShuffleArray(arr As Variant) As Variant Dim i As Long, j As Long Dim temp As Variant For i = UBound(arr) To LBound(arr) + 1 Step -1 j = Int((i - LBound(arr) + 1) * Rnd + LBound(arr)) temp = arr(i, 1) arr(i, 1) = arr(j, 1) arr(j, 1) = temp Next i ShuffleArray = arr End Function شرح الفكرة الثانية التي تمت :- بالذهاب الى التخلص من الدوال المساعدة ، أو تقييد الفكرة السابقة ، حيث تم استنباط فكرة أخرى تعمل على :- استخدام خوارزمية توزيع دائرية مباشرة بدون حاجة لفكرة خلط المصفوفات التي قد تكون ذات نتائج مختلفة في كل مرة عند التوزيع . ( وهي الفكرة التي خطرت ببالي سابقاً ) . الإعتماد على احتساب التكرارات أثناء التوزيع نفسه . معالجة البيانات كمصفوفات بدلاً من نطاقات خلايا !!!!! تقليل الوصول إلى ورقة العمل ، مما يساعد على الوصول الى نتيجة أسرع . اعتماد فكرة رسائل أكثر وصفية و تحتوي على أرقام الملاحظين واللجان . الكود الذي تم استخدامه لهذه الفكرة :- Sub DistributeObservers() On Error GoTo ErrorHandler Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("الثانوية العامة") Dim observers As Variant: observers = ws.Range("B3", ws.Cells(ws.Rows.Count, "B").End(xlUp)).Value Dim observerCount As Long: observerCount = UBound(observers) Dim committeeCount As Long: committeeCount = 30 ws.Range("A3:A" & observerCount + 2).ClearContents ws.Range("D3").Resize(observerCount, committeeCount).ClearContents Dim i As Long, j As Long For j = 1 To committeeCount For i = 1 To observerCount ws.Cells(i + 2, j + 3).Value = observers((i + j - 2) Mod observerCount + 1, 1) Next i Next j For i = 1 To observerCount ws.Cells(i + 2, 1).Value = Application.CountIf(ws.Range("D3").Resize(observerCount, committeeCount), observers(i, 1)) Next i MsgBox "تم توزيع " & observerCount & " ملاحظاً على " & committeeCount & " لجنة بنجاح", vbInformation + vbMsgBoxRight, "إنجاز" ErrorHandler: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic If Err.Number <> 0 Then MsgBox "خطأ " & Err.Number & ": " & Err.Description, vbCritical, "خطأ" End Sub وطبعاً في كلا الحالتين ، تم اضافة دالة ماكرو بسيطة لمسح القيم وتنظيف الجدول من التوزيعات :- Sub ClearDistribution() Application.ScreenUpdating = False On Error Resume Next Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets("الثانوية العامة") Dim lastRow As Long lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).row ws.Range("D3:AH" & lastRow).ClearContents ws.Range("A3:A" & lastRow).ClearContents Application.ScreenUpdating = True MsgBox "تم مسح بيانات التوزيع بنجاح", vbInformation + vbMsgBoxRight, "" End Sub الملفين للفكرتين :- ملاحظة_ث.ع - 1.xlsm ملاحظة_ث.ع - 2.xlsm

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

أعتقد ان إستبدال هدا السطر سيوفي بالغرض من If xtbl > 0 Then Sh1.Range("A5").Resize(xtbl, 13).Value = Application.Index(v, Evaluate("ROW(1:" & xtbl & ")"), Evaluate("COLUMN(1:13)")) End If إلى If xtbl > 0 Then If xtbl = 1 Then Sh1.Range("A5").Resize(1, 13).Value = v Else Sh1.Range("A5").Resize(xtbl, 13).Value = v End If End If بطريقة مختلفة وأسرع نوعا ما Private Sub CommandButton1_Click() Dim i&, r&, c&, k&, t&, f&, xtbl&, lastRow&, n As Boolean, ok As Boolean, val$ Dim s, data, a(), ky(), tb(), j(), criteria() SetApp False ReDim ky(1 To MaxCombo): ReDim tb(1 To MaxCombo): ReDim j(1 To MaxCombo) For i = 1 To MaxCombo val = Trim(LCase(Me("ComboBox" & i).Value)) If val <> "" And val <> "*" Then ky(i) = val: n = True Else ky(i) = "" Next If Not n Then MsgBox "الرجاء تحديد معايير البحث", vbExclamation: GoTo CleanUp For i = 1 To MaxCombo If ky(i) <> "" Then f = f + 1: tb(f) = ColArr(i - 1): j(f) = ky(i) Next With Sh1 lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row If lastRow >= 5 Then .Range("A5:M" & lastRow).ClearContents End With data = OnRng: k = UBound(data, 1): t = 13 ReDim a(1 To k, 1 To t), criteria(1 To f) For r = 1 To k ok = True For i = 1 To f s = data(r, tb(i)) criteria(i) = IIf(IsDate(s), Format$(s, "yyyy/mm/dd"), LCase(Trim(CStr(s)))) If criteria(i) <> j(i) Then ok = False: Exit For Next If ok Then xtbl = xtbl + 1 For c = 1 To t: a(xtbl, c) = data(r, c): Next If IsDate(a(xtbl, 9)) Then a(xtbl, 8) = xDayName(Format(a(xtbl, 9), "dddd")) If IsDate(a(xtbl, 12)) Then a(xtbl, 11) = xDayName(Format(a(xtbl, 12), "dddd")) End If Next If xtbl > 0 Then Sh1.Range("A5").Resize(xtbl, t).Value = a AddBorders Sh1.Name CleanUp: SetApp True End Sub توحيد البحث في شيت واحد v7.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته اخي @AMIRBM تم تعديل الكود حسب طلبك ليعرض عمودين في ListBox داخل نموذج البحث مثلا (الإسم + التسلسل) يمكنك تعديله بما يناسبك وقد قمت بمحاولة تنقيحه وتحسينه ليكون أكثر كفاءة وتنظيما يرجى أولا تفريغ جميع الأكواد السابقة من النموذج ثم نسخ الكود التالي بالكامل Option Explicit Private ColArr As Variant Public Property Get WS() As Worksheet: Set WS = Sheets("add"): End Property Public Property Get dest() As Worksheet: Set dest = Sheets("search"): End Property Private Sub UserForm_Initialize() TextBox1.SetFocus 'قم بتحديد الأعمدة المرغوب عرضها ColArr = Array(2, 1) ' 2 = الإسم / 1 = التسلسل With ListBox1: .ColumnCount = UBound(ColArr) + 1: .ColumnWidths = "100pt;40pt": End With End Sub Private Sub TextBox1_Change() Dim c As Range, tmp As String, lastRow As Long, i As Long, listCount As Long ListBox1.Clear If IsEmpty(ColArr) Then Exit Sub tmp = Trim(TextBox1.Value) If Len(tmp) = 0 Then Exit Sub SetApp False lastRow = WS.Cells(WS.Rows.Count, ColArr(0)).End(xlUp).Row For Each c In WS.Range(WS.Cells(5, ColArr(0)), WS.Cells(lastRow, ColArr(0))) If InStr(1, c.Value, tmp, vbTextCompare) > 0 Then ListBox1.AddItem c.Value listCount = ListBox1.listCount For i = 1 To UBound(ColArr) ListBox1.List(listCount - 1, i) = c.EntireRow.Cells(1, ColArr(i)).Value Next i End If Next c SetApp True End Sub Private Sub CommandButton1_Click() Dim Irow As Long, f As Long, i As Long, xName As String, cnt As Boolean: cnt = False If ListBox1.listCount = 0 Then MsgBox "لا توجد نتائج للبحث", vbExclamation, "تنبيه": Exit Sub xName = Trim(TextBox1.Value): Irow = WS.Cells(WS.Rows.Count, ColArr(0)).End(xlUp).Row SetApp False For i = 5 To Irow If WS.Cells(i, ColArr(0)).Value = xName Then If Not cnt Then dest.Range("A8:L" & dest.Rows.Count).ClearContents f = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1 dest.Range("A" & f).Resize(1, 12).Value = WS.Cells(i, 2).Resize(1, 12).Value cnt = True End If Next i If Not cnt Then MsgBox "لم يتم العثور على الاسم" & xName & " ضمن كشف المرحليات", vbInformation, "نتيجة البحث" SetApp True: Unload Me End Sub Private Sub ListBox1_Click() TextBox1.Value = ListBox1.List(ListBox1.ListIndex, 0) End Sub Private Sub SetApp(ByVal enable As Boolean) On Error Resume Next With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With On Error GoTo 0 End Sub المرحليات أوفيسنا v2.xlsm

وعليكم السلام ورحمة الله وبركانه لم توضح ارتباط العمود الثاتي بأيعم ود في الشيت اليك التعديل Private Sub TextBox1_Change() ListBox1.Clear Application.ScreenUpdating = False Dim ws As Worksheet: Set ws = Sheets("add") Dim lr As Long, c As Range, b As Integer, k As Long Dim arrData() As Variant Dim i As Long, j As Long lr = 0 For Each c In ws.Range("b5:b" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row) b = InStr(1, c.Value, TextBox1.Value, vbTextCompare) If b > 0 Then lr = lr + 1 ReDim Preserve arrData(1 To 2, 1 To lr) arrData(1, lr) = c.Value arrData(2, lr) = c.Offset(0, 4).Value End If Next c With ListBox1 .ColumnCount = 2 .ColumnWidths = "100;100" If lr > 0 Then .List = Application.Transpose(arrData) End If End With Application.ScreenUpdating = True End Sub في الكود السابق تم ربط العمود الثاني باسم المعلم يمكنك التعديل يالتغيير في رقم 4 فهي تشير الى رقم العمود في الشيت بعد عمود الاسم arrData(2, lr) = c.Offset(0, 4).Value كنا يمكنك من تعديل عرض العمود بالتعديل في رقمي 100 الاول للعمود الاول والثانية للعمود الثاني .ColumnWidths = "100;100" ارجو ما قدمته ان يكون طلبك كل عام وانت بخير المرحليات أوفيسنا.xlsm

السلام عليكم ورحمة الله وبركاته تم تحسين سرعة الكود اي تغيير في I2 -13-14 يعمل الكود الترقيم التلقائي في العمود B تم تعديل المعادلة في العمود الاخير بحيت تظعر الارقام حيب اخر بيان في العمود C جرب الكود وان كان هناك أي استفسار فلا حرج اعاده الله عليك يالخير والبركة يومية النقدية 1العامة.xlsm

ما شاء الله جزاكم الله خيرا على هذا العمل الرائع والفكرة المميزة اخي @Foksh بناء على هده الفكرة القيمة قمت بتطوير الكود بحيث عند وجود أكثر من اختلاف بين القيم (قبل وبعد) يتم تمييز كل اختلاف بلون مختلف هذا فعلا يسهل جدا معرفة وتتبع الفروقات كما دكرت مع إظافة استخراج المادة التي تحتوي على الاختلاف إلى جانب الاسم والقيمة القبلية والبعدية لتوفير عرض واضح ومباشر للفروقات بالتوفيق......... نسخة معدلة من الكود لتحقيق هذا الهدف Private Sub Worksheet_Change(ByVal Target As Range) Dim r As Long, c As Long, Tbl1, Tbl2, a, b, tmp As Long, xCount As Long, key As String Dim xColor, cnt As Object, j As Long, i As Long, x As Long, ky As String Const départ = 3, ColArr = 18, début = 2, LastCol = 9, f = 9, Irow = 1 If Target.CountLarge > 1 Then Exit Sub Set cnt = CreateObject("Scripting.Dictionary") xColor = Array( _ RGB(255, 255, 0), RGB(255, 0, 0), RGB(0, 176, 80), RGB(0, 112, 192), RGB(255, 192, 0), RGB(112, 48, 160), _ RGB(255, 0, 255), RGB(0, 176, 240), RGB(146, 208, 80), RGB(255, 102, 0), RGB(204, 0, 153), RGB(0, 255, 255), _ RGB(255, 153, 204), RGB(153, 51, 0), RGB(102, 102, 255), RGB(255, 204, 153), RGB(51, 153, 102), RGB(153, 0, 0), _ RGB(0, 102, 204), RGB(204, 153, 255), RGB(255, 255, 153), RGB(204, 0, 0), RGB(0, 153, 0), RGB(0, 51, 102), _ RGB(255, 128, 0), RGB(102, 0, 102), RGB(0, 204, 204), RGB(255, 102, 102), RGB(102, 255, 102), RGB(102, 102, 153)) On Error GoTo CleanUp With Me If Intersect(Target, .Range(.Cells(départ, début), .Cells(départ + ColArr - 1, LastCol + f))) Is Nothing Then Exit Sub SetApp False .Range(.Cells(départ, début), .Cells(départ + ColArr - 1, LastCol + f)).Interior.colorIndex = xlNone With .Range("T:W"): .UnMerge: .ClearContents: End With Me.[T1:W1].Value = Array("الإسم", "المادة", "قبل", "بعد") tmp = 2: j = 0: xCount = 0 For r = départ To départ + ColArr - 1 b = .Cells(r, Irow).Value For c = début To LastCol Tbl1 = .Cells(r, c).Value: Tbl2 = .Cells(r, c + f).Value: a = .Cells(2, c).Value If IsEmpty(Tbl1) Then Tbl1 = "" If IsEmpty(Tbl2) Then Tbl2 = "" If CStr(Tbl1) <> CStr(Tbl2) Then xCount = xCount + 1 key = b & "|" & a & "|" & Tbl1 & "|" & Tbl2 If Not cnt.Exists(key) Then cnt.Add key, xColor(j Mod (UBound(xColor) + 1)) j = j + 1 End If .Cells(r, c).Interior.Color = cnt(key) .Cells(r, c + f).Interior.Color = cnt(key) .Cells(tmp, "T").Resize(1, 4).Value = Array(b, a, Tbl1, Tbl2) tmp = tmp + 1 End If Next c Next r If xCount > 0 Then .Cells(tmp, "T").Value = "إجمالي الاختلافات" .Cells(tmp, "U").Value = xCount x = 2: ky = .Cells(x, "T").Value For i = 3 To tmp If .Cells(i, "T").Value <> ky Or .Cells(i, "T").Value = "" Then If i - 1 > x Then .Range("T" & x & ":T" & i - 1).Merge x = i ky = .Cells(i, "T").Value End If Next i Else With .Range("T:W"): .UnMerge: .ClearContents: End With End If CleanUp: SetApp True Set cnt = Nothing End With End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub درجات المواد v4.xlsb

ما شاء الله ، تبارك الله .. أفكار وحلول جميلة ، من الأساتذة ( @hegazee ، @محمد هشام. ... ) ، ولهذا وددت أيضاً تطوير الفكرة بحيث عند وجود أكثر من فارق بين ( قبل وبعد ) في نفس الصف ، ان يتم تمييز كل فارق بلون مختلف لتسهل معرفة وتتبع الفروقات عند السجلات الكبيرة . حيث تم تعديل الدالة الرئيسية فقط كالآتي :- Public Sub HighlightGradeDifferencesGeneral(ByVal sheetObject As Worksheet, _ ByVal rangeBeforeAddress As String, _ ByVal rangeAfterAddress As String, _ Optional ByVal showMessage As Boolean = True) Dim rangeBefore As Range Dim rangeAfter As Range Dim cellAfter As Range Dim cellBefore As Range Dim i As Long Dim j As Long Dim colorPalette As Variant Dim colorIndex As Long colorPalette = Array(6, 3, 4, 7, 8, 9, 10, 12) On Error GoTo ErrorHandler Set rangeBefore = sheetObject.Range(rangeBeforeAddress) Set rangeAfter = sheetObject.Range(rangeAfterAddress) If rangeBefore.Rows.Count <> rangeAfter.Rows.Count Or _ rangeBefore.Columns.Count <> rangeAfter.Columns.Count Then If showMessage Then MsgBox "نطاق 'قبل' (" & rangeBeforeAddress & ") ونطاق 'بعد' (" & rangeAfterAddress & ") " & _ "في الورقة '" & sheetObject.Name & "' ليسا بنفس الأبعاد . يرجى التحقق", vbExclamation + vbMsgBoxRight, "" End If Exit Sub End If Application.EnableEvents = False Application.ScreenUpdating = False rangeBefore.Interior.colorIndex = xlNone rangeAfter.Interior.colorIndex = xlNone For i = 1 To rangeAfter.Rows.Count colorIndex = 0 For j = 1 To rangeAfter.Columns.Count Set cellAfter = rangeAfter.Cells(i, j) Set cellBefore = rangeBefore.Cells(i, j) If Not IsEmpty(cellAfter.Value) And Not IsEmpty(cellBefore.Value) Then If cellAfter.Value <> cellBefore.Value Then cellAfter.Interior.colorIndex = colorPalette(colorIndex) cellBefore.Interior.colorIndex = colorPalette(colorIndex) colorIndex = (colorIndex + 1) Mod (UBound(colorPalette) + 1) End If ElseIf (IsEmpty(cellAfter.Value) And Not IsEmpty(cellBefore.Value)) Or _ (Not IsEmpty(cellAfter.Value) And IsEmpty(cellBefore.Value)) Then cellAfter.Interior.colorIndex = colorPalette(colorIndex) cellBefore.Interior.colorIndex = colorPalette(colorIndex) colorIndex = (colorIndex + 1) Mod (UBound(colorPalette) + 1) End If Next j Next i If showMessage Then MsgBox "اكتملت المقارنة وتم تلوين الاختلافات في الورقة '" & sheetObject.Name & "'.", vbInformation + vbMsgBoxRight, "" End If ErrorHandler: Application.ScreenUpdating = True Application.EnableEvents = True If Err.Number <> 0 And showMessage Then MsgBox "حدث خطأ في الورقة '" & sheetObject.Name & "': " & Err.Description, vbCritical + vbMsgBoxRight, "" End If End Sub الملف بعد إضافة التعديل درجات المواد.xlsm وصورة توضيحية للنتيجة

وعليكم السلام ورحمة الله تعالى وبركاته إليك الكود المطلوب لحفظ جميع الشهادات في ملف PDF داخل مجلد باسم برنامج الكنترول شيت في نفس مكان المصنف Option Explicit Private Const CopyRange As String = "A5:J49" Private Const sFolder As String = "برنامج الكنترول شيت" Private Const NamePDF As String = "شهادات الأول" Private Const CrWS As String = "شهادات الأول بالقديرات" Private Sub CommandButton1_Click() Dim tbl As Boolean: tbl = False On Error GoTo CleanExit Dim f As Worksheet: Set f = Sheets(CrWS) Dim WS As Worksheet, début As Integer, fin As Integer, i As Integer, row As Integer Dim sPath As String, tempFile As String, tmp As Long, Rng As Range, OnRng As Range If IsEmpty(f.[J3].Value) Or Not IsNumeric(f.[J3].Value) Then _ MsgBox "يرجى تحديد رقم أول شهادة", vbExclamation, "تنبيه": Exit Sub début = f.[J3].Value: fin = f.[R3].Value If début < 1 Or fin < 1 Or début > fin Then Exit Sub If MsgBox("هل ترغب بحفظ الشهادات من " & _ début & " إلى " & fin & "؟", vbYesNo + vbExclamation, "تأكيد") = vbNo Then Exit Sub SetApp False On Error Resume Next Set WS = Sheets("PDF") If Not WS Is Nothing Then Application.DisplayAlerts = False: WS.Delete: Application.DisplayAlerts = True Set WS = Sheets.Add(After:=Sheets(Sheets.Count)) WS.Name = "PDF": WS.DisplayRightToLeft = True On Error GoTo 0 If WS Is Nothing Then: GoTo CleanExit tempFile = ThisWorkbook.Path & "\" & sFolder If Dir(tempFile, vbDirectory) = "" Then MkDir tempFile tmp = 1 Set OnRng = f.Range(CopyRange) For i = début To fin Step 5 f.[J3].Value = i: Set Rng = WS.Cells(tmp, 2) OnRng.Copy Rng.PasteSpecial Paste:=xlPasteValues: Rng.PasteSpecial Paste:=xlPasteFormats Rng.PasteSpecial Paste:=xlPasteColumnWidths For row = 1 To OnRng.Rows.Count WS.Rows(tmp + row - 1).RowHeight = OnRng.Rows(row).RowHeight - 1.5 Next If i + 5 <= fin Then WS.HPageBreaks.Add Before:=WS.Cells(tmp + OnRng.Rows.Count, 1) tmp = tmp + OnRng.Rows.Count + 1 Next With WS.PageSetup .Orientation = xlPortrait: .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False .TopMargin = Application.InchesToPoints(0.5): .BottomMargin = Application.InchesToPoints(0.5) .LeftMargin = Application.InchesToPoints(0.2): .RightMargin = Application.InchesToPoints(0.2) .PaperSize = xlPaperA4: .CenterHorizontally = True: .CenterVertically = False End With sPath = tempFile & "\" & NamePDF & ".pdf" On Error Resume Next WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPath, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False tbl = (Err.Number = 0) On Error GoTo 0 f.[J3].Value = 1 WS.Delete CleanExit: SetApp True MsgBox IIf(tbl, _ "تم تصدير جميع الشهادات بنجاح" & vbNewLine & _ "تم حفظ الملف باسم: " & NamePDF & vbNewLine & "في المجلد: " & sFolder, _ "حدث خطأ يرجى المحاولة مرة أخرى"), IIf(tbl, vbInformation, vbCritical), _ "PDF" & "تصدير الشهادات بصيغة" End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable End With End Sub وإليك في المرفقات شكل الملف PDF المستخرج بعد تنفيذ العملية لتأخذ فكرة واضحة عن النتيجة النهائية شهادات الأول والثانى- الصف الأول.rar شهادات الأول.pdf

جرب المعادلة التالية =IF($B10="","",ROUND(VLOOKUP($B10,nageh,25,0), 0)) لا تنسى تحويل الفواصل حسب إصدار الأوفيس عندك

وعليكم السلام ورحمة الله وبركاته ،، أتمنى أن تكون الصورة قد وضحت لي وتم فهمها بالشكل الصحيح 😅 .. انظر للصورة الأولى :- والنتيجة للصورة الثانية :- هل تلبي المطلوب بالشكل الصحيح ؟ خبرتي في اكسل قليلة جداً مقارنة مع الأساتذة ( دون استثناء ) في هذا الصرح الكبير . التنفيذ تم باستخدام الماكرو التالي :- Sub FillAccountNum() Dim ws As Worksheet Dim lastRow As Long Dim i As Long, j As Long Dim accountVal As String Set ws = ActiveSheet lastRow = ws.Cells(ws.Rows.Count, "K").End(xlUp).Row For i = 2 To lastRow If InStr(1, ws.Cells(i, "K").Value, "متبقي تعاقد مشروع قسط") > 0 Then For j = i + 1 To lastRow If Trim(ws.Cells(j, "A").Value) Like "Account*" Then accountVal = ws.Cells(j, "A").Value ws.Cells(i, "A").Value = accountVal Exit For End If Next j End If Next i End Sub المرفق بعد التنفيذ :- EXPORT.xlsm وفيما يلي ، توضيح لتفعيل وضع المطور واختيار الماكرو للشيت الحالي .. جرب وأخبرني بالنتيجة ، للمتابعة .

ConvertDates.rar

وعليكم السلام ورحمة الله وبركاته جرب هدا Option Explicit Const Salaries As Double = 250000 Sub SplitTables() Dim WS As Worksheet, Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet Dim lastRow As Long, i As Long, Tbl1 As Long, Tbl2 As Long, tbl3 As Long, arr Dim sum1 As Double, sum2 As Double, sum3 As Double, OnRng As Range, CrWS As Variant Dim tmp() As Double, n() As Long, ky() As Boolean, j() As Boolean, k() As Boolean SetApp False Set WS = ThisWorkbook.sheets("Net") TmpWS "تقسيم1": TmpWS "تقسيم2": TmpWS "تقسيم3" Set Sh1 = ThisWorkbook.sheets("تقسيم1") Set Sh2 = ThisWorkbook.sheets("تقسيم2") Set Sh3 = ThisWorkbook.sheets("تقسيم3") CrWS = Array(Sh1, Sh2, Sh3) For Each arr In CrWS arr.Columns("A:H").Clear arr.DisplayRightToLeft = True Next lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row ReDim tmp(2 To lastRow), n(2 To lastRow), ky(2 To lastRow) ReDim j(2 To lastRow), k(2 To lastRow) For i = 2 To lastRow tmp(i) = WS.Cells(i, "D").Value n(i) = i Next i Set OnRng = WS.[A1:H1] OnRng.Copy Sh1.[A1]: OnRng.Copy Sh2.[A1]: OnRng.Copy Sh3.[A1] Tbl1 = 2: Tbl2 = 2: tbl3 = 2: sum1 = 0: sum2 = 0: sum3 = 0 For i = 2 To lastRow If tmp(i) > Salaries Then WS.Rows(n(i)).Copy Sh3.Rows(tbl3) tbl3 = tbl3 + 1 ky(i) = True sum3 = sum3 + tmp(i) End If Next i If Not WsTotal(tmp, ky, Salaries, j) Then Call WsTotal(tmp, ky, Salaries, j) For i = 2 To lastRow: If j(i) Then ky(i) = True Next i If Not WsTotal(tmp, ky, Salaries, k) Then Call WsTotal(tmp, ky, Salaries, k) For i = 2 To lastRow If j(i) Then WS.Range("A" & n(i) & ":H" & n(i)).Copy Sh1.Range("A" & Tbl1) sum1 = sum1 + tmp(i) Tbl1 = Tbl1 + 1 ElseIf k(i) Then WS.Range("A" & n(i) & ":H" & n(i)).Copy Sh2.Range("A" & Tbl2) sum2 = sum2 + tmp(i) Tbl2 = Tbl2 + 1 ElseIf Not ky(i) Then WS.Range("A" & n(i) & ":H" & n(i)).Copy Sh3.Range("A" & tbl3) sum3 = sum3 + tmp(i) tbl3 = tbl3 + 1 End If Next i AddTotal Sh1, Tbl1, sum1: AddTotal Sh2, Tbl2, sum2: AddTotal Sh3, tbl3, sum3 ColArr CrWS WS.Activate MsgBox "تم تقسيم جدول الرواتب بنجاح", vbInformation SetApp True End Sub Private Sub AddTotal(sht As Worksheet, ling As Long, total As Double) sht.Cells(ling, "C").Value = "الإجمالي" sht.Cells(ling, "D").Value = Format(total, "0.00") With sht.Range(sht.Cells(ling, "C"), sht.Cells(ling, "D")) .Font.Bold = True: .Interior.Color = RGB(220, 230, 241) End With End Sub Private Sub ColArr(sheets As Variant) Dim sht As Variant For Each sht In sheets sht.Columns("A:H").AutoFit Next sht End Sub Private Sub TmpWS(sheetName As String) Dim WS As Worksheet On Error Resume Next Set WS = ThisWorkbook.sheets(sheetName) On Error GoTo 0 If WS Is Nothing Then Set WS = ThisWorkbook.sheets.Add(After:=ThisWorkbook.sheets(ThisWorkbook.sheets.Count)) WS.Name = sheetName End If End Sub حافظة إلكترونية مصارف التجاري052025 V-2.xls

وعليكم السلام ورحمة الله تعالى وبركاته يرجى ملاحظة أنه في دالة SUMIF يجب أن تكون القيم متطابقة تماما بما في ذلك المسافات الزائدة في بداية أو نهاية النص وهذا لا ينطبق على ملفك الحالي حيث توجد بعض القيم في العمود (j) تحتوي على مسافات إضافية E5 عشاء ________ متطابقة E6 أغراض _______ تتضمن مسافة في البداية E7 اخرى _________ تتضمن مسافة في النهاية للتأكد من ذلك يمكنك نسخ القيم من العمود (O) ولصقها في العمود (J) مباشرة وإستخدام المعادلة المقترحة من الأستاد @عبدالله بشير عبدالله وستلاحظ أن النتائج تبدأ بالظهور بشكل صحيح كما يمكنك استخدام الصيغة التالية لتجاوز هذه المشكلة والتأكد من وجود تطابق بعد إزالة المسافات =IF(J13<>"", SUMPRODUCT(($F$5:$F$28)*((TRIM($E$5:$E$28)=TRIM(J13)))), "") حساب011.xlsx

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

الصف الأول / النصف الأول : يوجد 21 طالبا حاصلون على الدرجة الكبرى 400 كيف تتعامل معهم ؟ كلهم الاول مكرر .. هذا هو العدل يوجد 11 طالب خارج الحسبة اذا اخترت حسب شروطك .. فلذي اسمه يااسر او ياسين او يارا ... الخ نحاسب اهاليهم ليه اختاروا لهم هذه الأسماء حتى تواريخ الميلاد نقص ايام او شهر ، هل تعطي افضلية ؟

صدقت تماماً .. لم لا نحصل على عدد ايام الحضور بطريقة تعتمد على الجدول المؤقت بدلاً من الاستعلامات !!!!! فكرة بسيطة

تسطيع عمل ذلك بشكل سريع وذلك بإتباع الآتي : تضع مؤشر الماوس على المكان الذي تريد أن تكتب فيه التاريخ . الضغط على المفاتيح ALT+SHIFT+D بعدها سوف تجد ان التاريخ تم إدراجه ويتم تحديثه تلقائيا كل يوم . تستطيع عمل نفس الشى بالنسبة للوقت وذلك بالضغط على ALT+SHIFT+T

سؤالك وجيه يا أخ أبو مشاري ... أنا عرفت طريقة و هي كالتالي 1- من قائمة insert اختر أمر Date & time 2- اختر الشكل الذي يعجبك لإظهار التاريخ 3- ضع علامة صح في update automatically التحديث ما يتم الا اذا أغلقت الملف وفتحته مره أخرى اذا ما كان فيه ولا شكل للتاريخ عاجبك تقدر تسوي واحد بنفسك حسب اللي تبيه عن طريق: 1- من قائمة insert اختر أمر Field 2- اختر تحت كلمة Date & Time , Categories 3- أدخل الشكل الذي تريد تحت كلمة Date Format for day (d) , for month(m) , for year(y) انظر إلى هذه الصفحة و ستريك الأشكال المتعددة الممكن إدراجها شرح أشكال التاريخ و الوقت ولكن لدي سؤال لأهل الخبرة ... هل يمكن وضع الأيام بالحروف الكبيرة تلقائيا مثل SUNDAY .. لأنني لاحظت أن البرنامج يضع الحرف الأول كبير فقط مثل Sunday؟؟