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

وعليكم السلام ورحمة الله وبركاته المعادلة =SUMIFS(C:C; B:B; ">=" & DATE($E$4;1;1); B:B; "<=" & DATE($E$4;12;31)) الملف جمع القيم بناء على السنة.xlsx وفقكم الله

شكرا جزيلا اخي الفاضل وبارك الله فيك وأكثر الله من امثالك وزادك الله من علمه

السلام عليكم الاستاذ محمد هشام اهنئك على الكود الرائع اعتقد انه يقصد جمع الارقام في التاريخ المتشابه بمعنى OnRng(n, tmp + 1) = OnRng(n, tmp + 1) & "-" & g(i, 1) بدل الشرطة بربد جمعة OnRng(n, tmp + 1) = OnRng(n, tmp + 1) + g(i, 1) هذا حسب فهمى لطلبه والله اعلم وننتظر رأيه في الامر

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sub ItemsRollKgmsKnt() Dim d1 As Object, d2 As Object Dim OnRng() As Variant, a, g, d As Variant Dim tmp As Integer, n As Integer, mx As Integer Dim WS As Worksheet: Set WS = Sheets("KN") Set d1 = CreateObject("Scripting.Dictionary") Set d2 = CreateObject("Scripting.Dictionary") a = WS.Range("A2:A" & WS.[A65000].End(xlUp).Row).Value g = WS.Range("G2:G" & WS.[A65000].End(xlUp).Row).Value d = WS.Range("D2:D" & WS.[A65000].End(xlUp).Row).Value For i = 1 To UBound(a, 1) If IsNumeric(a(i, 1)) And a(i, 1) <> "" Then If Not d1.exists(a(i, 1)) Then d1(a(i, 1)) = d1.Count + 1 End If Next i mx = 31 ReDim OnRng(1 To d1.Count, 1 To mx + 1) For i = 1 To UBound(a, 1) If IsNumeric(a(i, 1)) And a(i, 1) <> "" Then n = d1(a(i, 1)) tmp = Day(CDate(d(i, 1))) If tmp >= 1 And tmp <= 31 Then OnRng(n, 1) = a(i, 1) If OnRng(n, tmp + 1) = "" Then OnRng(n, tmp + 1) = g(i, 1) Else OnRng(n, tmp + 1) = OnRng(n, tmp + 1) & "-" & g(i, 1) End If End If End If Next i With Sheets("MM") .Range("A2").Resize(d1.Count, mx + 1).Value = OnRng .Columns.AutoFit End With End Sub KNTPROD V1.xlsb

السلام عليكم ورحمة الله وبركاته تفضل واتمنى ان يحقق طلبك تم عمل قائمة اختيار (شاهد الصورة المرفقة) الكود Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("N5")) Is Nothing Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim wsSource As Worksheet Dim wsDest As Worksheet Dim schoolName As String Dim lastRow As Long Dim destRow As Long Dim i As Long Set wsSource = ThisWorkbook.Sheets("اسماء العاملين ") Set wsDest = ThisWorkbook.Sheets("طباعة كشف المدرسة") schoolName = Me.Range("N5").Value wsDest.Range("A9:Z" & wsDest.Cells(Rows.Count, "A").End(xlUp).Row).ClearContents destRow = 9 lastRow = wsSource.Cells(Rows.Count, "B").End(xlUp).Row For i = 7 To lastRow If wsSource.Cells(i, 6).Value = schoolName Then wsDest.Cells(destRow, 1).Value = destRow - 8 wsDest.Cells(destRow, 2).Resize(, 4).Value = wsSource.Cells(i, 2).Resize(, 4).Value wsDest.Cells(destRow, 9).Value = wsSource.Cells(i, 6).Value destRow = destRow + 1 End If Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End If End Sub الملف سرى الشهادة الاعدادية.xlsb سرى الشهادة الاعدادية.xlsb

عااااااااااااااااش يافوكش يابطل

سألتك تشرح لي ولم تفعل على كل حال لم يمر بي شيء اسمه حركة الصنف كجدول منفصل وانما حركة الصنف تؤخذ من جدول الحركة الوحيد للعلم انه يمكننا استخراج الارصدة للاصناف والمخازن وحركة المخازن عند استخدام الحقل الواحد للكمية والحقل الواحد للمبالغ ولكن من اجل تخفيف الادوات مستقبلا ولسهولة التصفية والعمليات الحسابية ولأنك وضعت حقلا لنوع الحركة فالافضل صنع حقول على النحو التالي : 1- حقل للكمية الواردة وآخر للمنصرفة حقل الكمية الواردة ويرصد فيه : ( كمية المشتريات / كمية مرتجع البيع ) حقل الكمية الصادرة ويرصد فيه ( كمية المبيعات / كمية مرتجع الشراء / المحول للمخازن الأخرى ) ------------------------ 2- حقل لمبلغ الشراء وحقل آخر لمبلغ البيع اضافة الى الحقول الأخرى كمعرف الصنف ومعرف الفاتورة _________________________________________________ هنا وباستخدام استعلام بسيط واحد يمكنك التصفية وحساب اي شيء

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Dim PassProtect As String, OnRng As Range Private Const Clé As String = "1234" Public Property Get WS() As Worksheet: Set WS = Sheets("Sheet1"): End Property Sub Data_Protection() Dim linge As Variant Do linge = Application.InputBox("أدخل رقم الصف الأخير لقفل الخلايا", Type:=1) If linge = False Then Exit Sub If Not IsNumeric(linge) Or linge < 1 Or linge > WS.Rows.Count Then: MsgBox "خطأ في الإدخال" Exit Do Loop Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' قم بتعديل النطاق بما يناسبك Set OnRng = WS.Range("A2:M" & linge) With WS If .ProtectContents Then .Unprotect password:=Clé .Cells.Locked = False OnRng.FormulaHidden = True OnRng.Locked = True .Protect password:=Clé End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox linge & ":" & "تم قفل الحسابات بنجاح لغاية الصف ", vbInformation End Sub '======================================================================= Sub Data_UnProtection() Dim result As VbMsgBoxResult Do PassProtect = InputBox("أدخل كلمة المرور لفك الحماية") If PassProtect = "" Then Exit Sub If PassProtect = Clé Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual WS.Unprotect password:=Clé WS.Cells.Locked = False WS.Cells.FormulaHidden = False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم فتح جميع الحسابات بنجاح", vbInformation Exit Sub Else result = MsgBox( _ "كلمة المرور غير صحيحة" & vbNewLine & "هل ترغب في المحاولة مرة أخرى؟", _ vbCritical + vbYesNo, "خطأ في كلمة المرور") If result = vbNo Then MsgBox "تم إلغاء العملية", vbInformation Exit Sub End If End If Loop End Sub غلق المدى المحدد .xlsb

اخي الكريم ، اذا كان هدفك هو فتح النموذج بشرط السجل المحدد :- DoCmd.OpenForm "calculated_frm", , , "CustomerID = " & Me!CustomerID او ، قم بالتوضيح كونك قمت بتعديل طلبك في المشاركة الأولى

السلام عليكم ورحمة الله وبركاته عن طريق الكود ويمكن اضافة اي حرف احتمال يحدث فيه اختلاف شاهد المرفق بحث حتى لو فى اخلاتف بسيط1.xls وفقك الله

وعليكم السلام ورحمة الله وبركاته بدون ارفاق ملف ندخل في باب الاحتمالات اما .... واما الرسالة المعروضة تعني أن هناك عنصرًا (مثل ActiveX أو مكون في UserForm كـ ListBox أو ComboBox او غيره) في النموذج الخاص بك اوفي الاكواد غير متوفر على جهازك. بمكنك معرفة الكائن او المكتبة الغير متوفرة من خلال :- 1- الكود 2- او الانتقال إلى Developer > Visual Basic > Tools > References اذا وجدت كلمة MISSING (بمعنى مفقود) المكتوب امام الكلمة هي المكتبة المفقودة الصورة المرفقة كمثال لمكتبة مفقودة 3- الغاء التاشير من كلمة MISSING قد يحل المشكلة احيانا وليس دائما اتمنى ان اكون قدمت لك ما يقيد لك وافر التقدير والاحترام

وعليكم السلام ورحمة الله تعالى وبركاته بما أنك تستخدم الأكواد على الملف أعتقد أنه بإمكانك ربط الكود بأي شكل وتقوم بوضعه فوق الصورة عادي نفس الفكرة المقترحة من الأخ @أبومروان بواسطة الأكواد مع إمكانية تحديد إسم الصورة والتعليق المرغوب إظهاره .يمكنك إظافة أي عدد من الأشكال وتعديل النطاقات بما يتناسب مع إحتياجاتك wor-v2.xlsm

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

اليك حل اخر بالاكواد لعله يفيد حضرتك وممكن تعدل عليه علي حسب رغبه حضرتك Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim hijriDate As String ' تعيين الورقة النشطة Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من تغيير اسم الورقة إذا كان مختلفًا ' التحقق إذا كان التغيير في النطاق X3 إلى آخر خلية تحتوي على بيانات If Not Intersect(Target, ws.Range("X3:X" & ws.Cells(ws.Rows.Count, "X").End(xlUp).Row)) Is Nothing Then ' العثور على آخر صف يحتوي على بيانات في العمود X lastRow = ws.Cells(ws.Rows.Count, "X").End(xlUp).Row ' تكرار عبر الصفوف من X3 إلى آخر صف For i = 3 To lastRow ' قراءة التاريخ الهجري من الخلية hijriDate = ws.Cells(i, "X").Value ' التحقق إذا كانت الخلية تحتوي على تاريخ If hijriDate <> "" Then ' التحقق إذا كان حرف "هـ" موجودًا بالفعل If InStr(hijriDate, "هـ") = 0 Then ' تحويل التاريخ إلى التنسيق المطلوب وإضافة حرف "هـ" ws.Cells(i, "X").Value = Format(hijriDate, "yyyy/mm/dd") & "هـ" End If End If Next i End If End Sub مثل التاريخ.xlsm

لتجربة الأصناف اختر من الأرقام 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1020 1400 1110 1000 الكاشير.xlsm

العقو اخي @tahar

ضع الأكواد التالية في حدث ورقة natiga Private Sub Worksheet_Activate() UpdateData End Sub '============ Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("A10:A25")) Is Nothing Then UpdateData End If End Sub '=========== Private Sub UpdateData() Dim ColmA As Variant, msg As String, i As Long, tmp As Variant, col As Long Dim WS As Worksheet: Set WS = ThisWorkbook.Sheets("Feuil1") Dim item As Range: Set item = WS.Range("K2:K9") Dim data As Range: Set data = WS.Range("L2:O9") For i = 10 To 25 ColmA = Me.Range("A" & i).Value Me.Range("B" & i).ClearContents If Trim(ColmA) = "" Then GoTo lig On Error Resume Next tmp = Application.Match(ColmA, item, 0) On Error GoTo 0 If Not IsError(tmp) Then msg = "بدون نتيجة" For col = data.Columns.Count To 1 Step -1 If Trim(data.Cells(tmp, col).Value) <> "" Then msg = data.Cells(tmp, col).Value Exit For End If Next col Me.Range("B" & i).Value = msg Else Me.Range("A" & i).Resize(1, 2).ClearContents MsgBox "الكود " & ColmA & " غير موجود", vbExclamation End If lig: Next i End Sub المعادلة =IF(A10="","",IFERROR(LOOKUP(2,1/(INDEX(Feuil1!$L$2:$O$9, MATCH(A10,Feuil1!$K$2:$K$9,0),0)<>""),INDEX(Feuil1!$L$2:$O$9,MATCH(A10,Feuil1!$K$2:$K$9,0),0)),"بدون نتيجة")) ppp7.xlsb

=IF(A14="","",IFERROR(LOOKUP(2,1/(INDEX($L$2:$O$9,MATCH(A14,$K$2:$K$9,0),0)<>"") ,INDEX($L$2:$O$9,MATCH(A14,$K$2:$K$9,0),0)),"بدون نتيجة")) معادلة الأستاد @عبدالله بشير عبدالله =IFERROR( IF(A14="", "", INDEX($L$2:$O$9, MATCH(A14, $K$2:$K$9, 0), AGGREGATE(14, 6, COLUMN($L$1:$O$1) / (INDEX($L$2:$O$9, MATCH(A14, $K$2:$K$9, 0), 0)<>""), 1) - COLUMN($L$1) + 1) ), "بدون نتيجة") Private Sub Worksheet_Change(ByVal Target As Range) Dim rngA As Range, rngB As Range, rngC As Range Dim tmp As Variant, result As String Dim cell As Range, col As Long Dim msg As String: msg = "بدون نتيجة" Set rngA = Me.Range("K2:K9") Set rngB = Me.Range("L2:O9") Set rngC = Me.Range("A14:A21") Application.ScreenUpdating = False Application.EnableEvents = False If Not Intersect(Target, Union(rngB, rngC)) Is Nothing Then For Each cell In rngC If Trim(cell.Value) <> "" Then tmp = Application.Match(cell.Value, rngA, 0) If Not IsError(tmp) Then result = msg For col = 4 To 1 Step -1 If Trim(rngB.Cells(tmp, col).Value) <> "" Then result = rngB.Cells(tmp, col).Value Exit For End If Next col cell.Offset(0, 1).Value = result Else cell.Resize(1, 2).ClearContents MsgBox "الكود " & cell.Value & " غير موجود", vbExclamation End If Else cell.Offset(0, 1).ClearContents End If Next cell End If Application.EnableEvents = True Application.ScreenUpdating = True End Sub ppp6.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا =IFERROR(IF(A14="","",LOOKUP(2,1/(INDEX($B$2:$E$9,MATCH(A14,$A$2:$A$9,0),0)<>""),INDEX($B$2:$E$9,MATCH(A14,$A$2:$A$9,0),0))),"بدون نتيجة") أو بإستخدام vba Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim Code As Variant, dataA As Variant, dataB As Variant Dim rngA As Range, rngB As Range, rngC As Range Dim tmp As Variant, result As String Dim cell As Range, col As Long Dim msg As String: msg = "بدون نتيجة" Set rngA = Me.Range("A2:A9") Set rngB = Me.Range("B2:E9") Set rngC = Me.Range("A14:A21") Application.ScreenUpdating = False Application.EnableEvents = False On Error GoTo CleanExit If Not Intersect(Target, Union(rngB, rngC)) Is Nothing Then dataA = rngA.Value dataB = rngB.Value For Each cell In rngC If Trim(cell.Value) <> "" Then tmp = Application.Match(cell.Value, rngA, 0) If Not IsError(tmp) Then result = msg For col = 4 To 1 Step -1 If Trim(dataB(tmp, col)) <> "" Then result = dataB(tmp, col) Exit For End If Next col cell.Offset(0, 1).Value = result Else Code = cell.Value cell.Resize(1, 2).ClearContents MsgBox "الكود " & Code & " غير موجود", vbExclamation End If Else cell.Offset(0, 1).ClearContents End If Next cell End If CleanExit: Application.EnableEvents = True Application.ScreenUpdating = True End Sub ppp.xlsb

وعليكم السلام- باركود IDAutomationHC39M Idautomationhc39m.zip

هذه مجموعة من الخطوط يمكنك تحميلها وتثبيتها في ويندوز واستعمالها في الاكسل أو الاكسس أو اي برنامج من برامج ميكروسوفت Code 128 Code 39 UPC-E QR Postnet UPC/ EAN I2of5 Intelligent Mail بالتوفيق

الملف مفتوح مواقيت الصلاة مفتوح.xlsb

مثال جمل لكسر الروتين والتعلم عن طريق الترفيه طريقة التعامل مع الأشكال وربطها بالخلايا حيث يتغير النص في الشكل مع تعديل الخلية ويمكن تحريك الأشكال في الملعب لتغيير ورسم خطة اللعب تشكيلة الفريق وخطة اللعب.xlsx

تفضل اخى الكريم الملف بعد ازالة التحديد كود نسخ البيانات.xlsm

استاذنا الفاضل أبوأحـمـد لقد اجتهدنا بالعمل على الكود الاصلى الذى سبق انك عملته واذا كان هناك تعديل او تصحيح نرجو اعطاء خبرتك Sub TR7el() Dim namsh As String Dim wk, wk2 As Worksheet Dim check As Boolean namsh = Format(ورقة1.Range("A3"), "yyyy-mm-dd") Set wk = Worksheets("ادخال البيانات") If namsh = Empty Then Beep MsgBox "لا يوجد يوم ", , "عفوا" wk.Range("A3").Select Exit Sub End If For Each wk2 In Worksheets If wk2.Name Like namsh Then check = True: Exit For Next If check = True Then MsgBox "تم ترحيل هذا اليوم مسبقا", , "عفوا" Exit Sub End If With ThisWorkbook .Sheets.Add(Before:=.Sheets(.Sheets.Count)).Name = namsh End With Set wk2 = Worksheets(namsh) wk.Range("U2:AD10").Copy wk2.Range("A2").PasteSpecial Paste:=xlPasteValues wk2.Range("A2").PasteSpecial Paste:=xlPasteFormats wk2.Range("h3:h10").Copy wk.Range("c3:c10").PasteSpecial Paste:=xlPasteValues wk2.Rows(2).RowHeight = 35 wk2.Rows("3:10").RowHeight = 25 wk2.Columns(1).ColumnWidth = 10 wk2.Columns(2).ColumnWidth = 7 wk2.Columns(3).ColumnWidth = 8 wk2.Columns(4).ColumnWidth = 8 wk2.Columns(5).ColumnWidth = 8 wk2.Columns(6).ColumnWidth = 8 wk2.Columns(7).ColumnWidth = 8 wk2.Columns(8).ColumnWidth = 8 wk2.Columns(9).ColumnWidth = 8 wk2.Columns(10).ColumnWidth = 8 MsgBox "تم الترحيل " wk.Activate SendKeys "{F2}" wk.Range("A3").Select wk.Range("A3") = Date wk.Range("A3") = "" 'wk.Range("e3:e10") = 0 'wk.Range("d3:d10") = 0 SendKeys "{ENTER}" End Sub

تفضل نسبة التحصيل العلمي للطلاب.xlsb

تفضل للارسال.xlsm

اتفضل يمكن تستفاد منه

يمكنك استعمال دالة sumifs للجمع باكثر من شرط في الخلية D6 =SUMIFS(Data!D:D,Data!C:C,C6,Data!A:A,">="&$C$4,Data!A:A,"<="&$E$4) بالتوفيق

السلام عليكم ورحمة الله استخدم الكود التالى بدلا من الكود السابق Sub Transfer() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, LR As Long Set ws = Sheets("vi") Set Sh = Sheets("DATA") LR = Sh.Range("B" & Rows.Count).End(3).Row + 1 Arr = Array(ws.Range("B3"), ws.Range("C7"), ws.Range("A6")) Sh.Range("B" & LR).Resize(, 3) = Arr End Sub

السلام عليكم أختنا الكريمة مرفق الملف به ماطلبتي إن شاء الله ملاحظة في مثل هذه الحال ، يمكنك حذف كثير من البيانات لتقليل حجم الملف علي الموقع يعني بدلا من بيانات أكثر من 10,000 طالب يكفي 100 أو 200 وفقط نأخذ المعادلة ونطبقها أنا عملت كده وبدلا من إرسال 27 أو 28 ميجا ، فقط 0.028 ميجا تجريب2.xlsx

Calendar.mdb

التاريخ الهجرى Officena DatePicker.mdb

ادراج رزنامة شهرية لسنة معينة و شهر معين (باختيارك) بدون يوم او يومين تحددهما بنفسك و اذا لم تحدد الايام (بمسح الخلايا المناسبة) يتم ادراج كامل الشهر Sub Give_date_without_same_days() With CommandButton1 .Left = 469: .Top = 18.5: .Width = 154.5 End With If Not IsNumeric([a2]) Or Not IsNumeric([b2]) _ Or [b2] < 1 Or [b2] > 12 _ Or IsEmpty([a2]) Or IsEmpty([b2]) Then MsgBox "أدخل أرقاماً صحيحة في الخلايا " & Chr(10) & "$ِِِA$2 and $B$2 " & Chr(10) _ & "وأعد المحاولة", vbOKOnly + vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "!...ٍSalim" Range("c4:Ag5").ClearContents Range("c4:Ag5").Borders.LineStyle = 0 GoTo Exit_Me End If With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlManual End With Dim Array_Days(), My_Days_Arabic() Dim Arab_Day(), My_Date_For_Print() Dim Array_Numbers() Dim t As Date, i%, k%, m%, x%, last_col% Dim y$ '============================== Array_Days = Array("sun", "mon", "tue", "wed", "thu", "fri", "sat") Arab_Day = Array("الأحد", "الإثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة", "السّبت") Array_Numbers = Array(1, 2, 3, 4, 5, 6, 7) last_col = Cells(5, Columns.Count).End(1).Column Range("c4").Resize(2, last_col).ClearContents Range("c4").Resize(2, last_col).Borders.LineStyle = 0 '================================= [a2] = Int([a2]): [b2] = Int([b2]) t = DateSerial([a2], [b2], 1) x = Day(Application.EoMonth(t, 0)) k = 1 For i = 1 To x y = Application.Index(Arab_Day, Application.Match(Weekday(t), Array_Numbers, 0)) If Trim(y) = Trim([d2].Value) Or _ Trim(y) = Trim([e2].Value) Then GoTo 2 ReDim Preserve My_Days_Arabic(1 To k): My_Days_Arabic(k) = y ReDim Preserve My_Date_For_Print(1 To k): My_Date_For_Print(k) = t k = k + 1 ' End If 2: t = t + 1 Next Range("C4").Resize(1, UBound(My_Days_Arabic)) = My_Days_Arabic Range("C5").Resize(1, UBound(My_Date_For_Print)) = My_Date_For_Print Range("C4").Resize(2, UBound(My_Days_Arabic)).Borders.LineStyle = 1 ActiveSheet.PageSetup.PrintArea = "" ActiveSheet.PageSetup.PrintArea = Range("a1").Resize(6, UBound(My_Days_Arabic) + 2).Address Exit_Me: Erase Array_Days: Erase Arab_Day: Erase Array_Numbers With Application .ScreenUpdating = True .Calculation = xlAutomatic .EnableEvents = True End With End Sub Private Sub CommandButton1_Click() Give_date_without_same_days End Sub Private Sub Worksheet_Activate() With CommandButton1 .Left = 469: .Top = 18.5: .Width = 154.5 End With End Sub الكود موجود ضمن الملف Date_sans_deux_jours.xlsm

يبدو أن هناك مشكلة بالنسبة لهذه الأداة مع الـ 64 بت يمكن استخدام بديل لها قم بالإطلاع على الملف ويمكنك تصدير الأكواد المرتبطة والفورم الخاص بها إلى ملفك Date Calendar In UserForm.rar