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

وعليكم السلام-يمكنك استخدام هذه المعادلة =SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(A1,1,"A"),2,"B"),3,"C"),4,"D"),5,"R"),6,"E"),7,"M"),8,"K"),9,"N"),0,"V") CODAGE1.xlsx

تفضل التعديل حسب فهمي لطلبك ملاحظة : الكود لا يعمل اذا كان الحقل مفتاح رئيسي Mahdi.rar

See this video https://www.youtube.com/watch?v=IHOe5PQgIEU&ab_channel=ExcelShortcutFundas

السلام عليكم الأمر بكل بساطة لا يوجد به خطأ فقط كان عليك جعل تنسيق هذه الخلية هكذا -تفضل [h]:mm sum attendance1.xls

واذا عندك لوحة مفاتيح كبيرة ، فهذه ارقام ارقامها ، ويجب اضافتها للكود : Case 96 To 105 'numeric pad جعفر

جرب هذا الكود Sub AdNumber() Dim Rs As Worksheet Dim FIND_RG As Range On Error GoTo Bay_Bay_Ya_Helween Set Rs = Sheets("الرصيد") Set FIND_RG = Rs.Range("B:B").Find(Rs.Range("L5"), Lookat:=1) If Not FIND_RG Is Nothing Then FIND_RG.Offset(, 5) = _ Val(FIND_RG.Offset(, 5)) + Val(Rs.Range("M5")) Rs.Range("M5") = vbNullString End If Bay_Bay_Ya_Helween: End Sub jassawi.xlsm

ممتاز استاذ محمد جعله الله فى ميزان حسناتك ورحم الله والديك

استخدم هذا الكود ...... Private Sub Text0_Change() On Error Resume Next Dim L As Integer L = Val(Len(Text0.Text) - 1) If Not Trim(Text0.Text) = "" Then If IsNumeric(Text0.Text) = False Then Text0.Text = Mid(Text0.Text, 1, L): Text0.SelStart = Len(Text0.Text) End If End If End Sub Private Sub Text2_KeyPress(KeyAscii As Integer) On Error Resume Next Select Case KeyAscii Case 48 To 57, 32 '(لإلغاء SPACE) KeyAscii = 0 End Select End Sub

بارك الله فيك استاذ سليم وبعد اذن حضرتك ولإثراء الحل بالمعادلات العادية -تفضل نسب وشرائح.xlsx

لديك حق استاذى الكريم سليم فنبهنا كثيراً جداً على ضرورة رفع ملف بالمشاركة ولكن بعد اذن حضرتك -يمكنك استخدام الكود هكذا , فكان عليك وضع جملة End If بالكود ثلاثة مرات أخرى قبل كلمة Next كما ترى Sub AAD_ASD() Dim R As Integer, M As Integer, N As Integer, O As Integer, p As Integer, Q As Integer, S As Integer, T As Integer Sheets("كهرباء").Range("A4:DZ1000").ClearContents Sheets("ميكانيكا").Range("A4:DZ1000").ClearContents Sheets("نجارة أثاث").Range("A4:DZ1000").ClearContents Sheets("زخرفة").Range("A4:DZ1000").ClearContents Sheets("صحي").Range("A4:DZ1000").ClearContents Sheets("إنشاءات").Range("A4:DZ1000").ClearContents Sheets("تشطيبات").Range("A4:DZ1000").ClearContents M = 4: N = 4: O = 4: p = 4: Q = 4: S = 4: T = 4 Application.ScreenUpdating = False For R = 4 To 1000 If Cells(R, 4) = "كهرباء" Then Range("A" & R).Resize(1, 115).Copy Sheets("كهرباء").Range("A" & M).PasteSpecial xlPasteValues Sheets("كهرباء").Range("A" & M).PasteSpecial xlPasteFormats Application.CutCopyMode = False M = M + 1 ElseIf Cells(R, 4) = "ميكانيكا" Then Range("A" & R).Resize(1, 115).Copy Sheets("ميكانيكا").Range("A" & N).PasteSpecial xlPasteValues Sheets("ميكانيكا").Range("A" & N).PasteSpecial xlPasteFormats Application.CutCopyMode = False N = N + 1 ElseIf Cells(R, 4) = "نجارة أثاث" Then Range("A" & R).Resize(1, 115).Copy Sheets("نجارة أثاث").Range("A" & O).PasteSpecial xlPasteValues Sheets("نجارة أثاث").Range("A" & O).PasteSpecial xlPasteFormats Application.CutCopyMode = False O = O + 1 ElseIf Cells(R, 4) = "زخرفة" Then Range("A" & R).Resize(1, 115).Copy Sheets("زخرفة").Range("A" & p).PasteSpecial xlPasteValues Application.CutCopyMode = False p = p + 1 If Cells(R, 4) = "صحي" Then Range("A" & R).Resize(1, 115).Copy Sheets("صحي").Range("A" & Q).PasteSpecial xlPasteValues Sheets("صحي").Range("A" & Q).PasteSpecial xlPasteFormats Application.CutCopyMode = False Q = Q + 1 If Cells(R, 4) = "إنشاءات" Then Range("A" & R).Resize(1, 115).Copy Sheets("إنشاءات").Range("A" & S).PasteSpecial xlPasteValues Sheets("إنشاءات").Range("A" & S).PasteSpecial xlPasteFormats Application.CutCopyMode = False S = S + 1 If Cells(R, 4) = "تشطيبات" Then Range("A" & R).Resize(1, 115).Copy Sheets("تشطيبات").Range("A" & T).PasteSpecial xlPasteValues Sheets("تشطيبات").Range("A" & T).PasteSpecial xlPasteFormats Application.CutCopyMode = False T = T + 1 End If End If End If End If Next MsgBox ("الحمد لله تـــم ترحيل الناجحين و الراسيسن إلى أوراق عمل جديدة ") Application.ScreenUpdating = True End Sub

وعليكم السلام فقط يمكتك استخدام هذه المعادلة =INDIRECT("'"&B3&"'!e21") Test1.xlsx

بسيطة وسهلة لا تفعل أكثر مما تراه بالصورة

وعليكم السلام-تفضل يمكنك استخدام هذا الكود Sub DeleteRow() Dim r As Long Dim FirstRow As Long Dim LastRow As Long FirstRow = 8 LastRow = Cells(Rows.Count, "I").End(xlUp).Row - 1 For r = LastRow To FirstRow Step -1 If Cells(r, "i") = "VISUALISEUR" Then Rows(r).Delete End If Next r End Sub VISUAL1.xlsm

بالطبع بعد اذن استاذنا الكبير سليم حاصبيا .... بالتأكيد يمكنك هذا من خلال اضافة هذا الكود بأكواد الفورم مع تعديل عرض العمود الذى تريده من داخل الكود Private Sub UserForm_Initialize() With Me.ListBox1 .ColumnWidths = "0;75;100;75;75;75;75;80;75;70" .Width = 700 End With End Sub كما ان هناك طريقة أخرى بدون أكواد وهى كتابة عرض الأعمدة التى تريده من داخل خصائص الليست بوكس ColumnWidths وذلك كما ترى بالصورة

في حدث تيكسبوكس1 change اكتب الحالة الشرطية اولا If textbox1="" then وهنا اكتب التكستات التي تريد افراعها : مثلا "" = textbox2 وهكذا وفي الاخير انهاء الشرط: End if

نعم هذا هو المطلوب بالضبط جزاكم الله عنا كل الخير 👍

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

Try This Macro Option Explicit Sub Hide_rows() Dim Main_Rg As Range Dim cel As Range Dim Min_date As Date, Max_date As Date show_rows With Sheets("نوفمبر 2020") Min_date = Application.Min(.Range("A2:B2")) Max_date = Application.Max(.Range("A2:B2")) Set Main_Rg = .Range("A4").CurrentRegion.Offset(1).Columns(2) For Each cel In Main_Rg.Cells If cel >= Min_date And cel <= Max_date Then cel.EntireRow.Hidden = True End If Next End With End Sub '++++++++++++++++++++++++++++++++++++++ Sub show_rows() Sheets("نوفمبر 2020").Rows.Hidden = False End Sub Om_hamz_hid_rowa.xlsm

اذا كنت قد فهمت عليك ما تريده لا حاجة للكود Adnan mushtaha.xlsx

جرب هذا الشيء sub PRINT_OUT Range("a1:f32").Printout end sub

بالنسبة للطلبي 2 جرب الكود التالي ضعه في Textbox1 فورم1 ادخل رقم الحساب وانقر زر انتر على لوحة المفاتيح Private Sub TextBox1_AfterUpdate() Dim ws As Worksheet: Set ws = Sheets("ورقة1") Dim lr, x lr = ws.Cells(Rows.Count, 3).End(3).Row For x = 2 To lr If TextBox1.Text = ws.Cells(x, 3).Text Then TextBox2.Value = ws.Cells(x, 4).Value TextBox3.Value = ws.Cells(x, 5).Value TextBox4.Value = ws.Cells(x, 6).Value ComboBox1.Value = ws.Cells(x, 7).Value Exit For End If Next x End Sub وهذا في Combobox1 Private Sub ComboBox1_Change() Sheets("ورقة2").Range("j8").Value = Me.ComboBox1.Value End Sub

لا يمكن العمل على هكذا ملف مع هذه الكمية الهائلة من الخلايا المدمجة (كل 4 او 5 أعمدة يشكلون خلية واحدة)

ما بها الرسالة هل تريد الغائها وعدم ظهورها ؟؟؟؟؟

تفضل ولاحظ التعديلات : كونت لك استعلام ونموذج لاستخراج الاجمالي copy.accdb

تغيير اسماء الصفحات الصفحة الأول "Main" والصفحة الاخيرة "Target"

الكود يعمل شكرا بارك الله فيك استاذ Ali Mohamed Ali

أ.Matin_Murad الأداة تعمل عندي بصورة صحيحة ولكن محاولة اخرى عسي تفيد .. شغل محرر الاوامر كمدير وذلك بعد نسخ الأداة الى المسارين السابق ذكرهما فى محرر الاوامر اكتب السطر الثانى regsvr32 C:\WINDOWS\SysWOW64\barcodex.ocx واضغط انتر فان لم تنجح فاكتب الامر الآخر regsvr32 C:\WINDOWS\system32\barcodex.ocx واضغط انتر فان لم تنجح فقم بتحميل الاداه المرفة .. جايز تكون اللى عندك معطوبة والله الموفق barcodex.rar

تعديل بسيط على الكود مع وضع معادلة مناسبة في العامود Z (يمكن اخفاءه) Private Sub CommandButton2_Click() Dim ws As Worksheet: Set ws = Sheets("inpout1") Dim lr As Integer Dim R, Ahe3b$, Hather$ Ahe3b = "غائب": Hather = "حاضر" ws.Range("w5:w500").ClearContents lr = ws.Range("b" & Rows.Count).End(xlUp).Row For R = 5 To lr ws.Cells(R, "W") = _ Choose(ws.Cells(R, "Z") + 1, Hather, Ahe3b) Next End Sub Khiri.xlsm

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

تم تعديل التصميم للشيت حيث النتائج (Target) لتبدو اكثر فهماً وصغت معيار النجاج 20 الذي هو 40/2 اذا اردت نغييره يمكن ذلك من خلال الكود (Const Fl_num=20) جرب هذا الكود Option Explicit Sub Get_data() Dim M As Worksheet Dim Tg As Worksheet Dim Max_ro%, i%, n As Byte Dim x%, t% Const Fl_num = 20 Set M = Sheets("Main") Set Tg = Sheets("Target") Max_ro = M.Cells(Rows.Count, 1).End(3).Row M.Range("A4:M" & Max_ro).Interior.ColorIndex = xlNone Tg.Range("B4:M500").Clear Select Case Tg.Range("A1") Case "الدخول": n = 6 Case "اللياقة": n = 7 Case "المهارة": n = 8 Case "الحاسب": n = 9 Case Else: Exit Sub End Select t = 4 For x = 4 To Max_ro If M.Cells(x, n) < Fl_num Then Tg.Cells(t, 2).Resize(, 13).Value = _ M.Cells(x, 1).Resize(, 13).Value ' M.Cells(x, 1).Resize(, 13).Interior.ColorIndex = 35 Union(M.Cells(x, n), M.Cells(x, 2)).Interior.ColorIndex = 35 t = t + 1 End If Next If t > 4 Then With Tg.Range("B4:N" & t - 1) .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True End With End If End Sub Youssef Hussein.xlsm

اعتقد فكرة اخونا عمر هي استخراج المجاميع في جدول جديد لاظهارها في التقرير وطبعا يتم حذف بيانات الجدول بمجرد غلق النموذج ، بمعنى ان الفكرة هي اظهار البيانات لحظية مؤقتة قابلة للتغيير والتحديث بالزيادة او النقص . وهنا نستغني عن الجدول وايضا النموذج والأزرار والأكواد المصاحبة هذه الدالة المصنوعة تحقق المطلوب Public Function studentscount(ByVal i As Byte) Dim z As Integer If i = 0 Then z = DCount("[student_name]", "[student]", "[state_code]<3") ElseIf i = 1 Then z = DCount("[student_name]", "[student]", "[state_code]<3 and [school_code]=1") ElseIf i = 2 Then z = DCount("[student_name]", "[student]", "[state_code]<3 and [school_code]=2") ElseIf i = 3 Then z = DCount("[student_name]", "[student]", "[state_code]<3 and [school_code]=3") Else End If studentscount = z End Function ويتم نداءها داخل الحقل سواء في النماذج او التقارير هكذا : للمجموع الكلي = studentscount(0) الابتدائي = studentscount(1) المتوسط = studentscount(2) الثانوي = studentscount(3) وهذا المرفق : إحصاء2_2003.rar

استاذ علي لا ضرورة اكل هذه الحلقات التكرارية (من 4 الى 1000) بكفي حلقة صغيرة جداُ حسب عدد الصفحات(7) كل حلقة تقوم بــ Auto filter على الجدول في الصفحة الرئيسية حسب اسم كل صفحة ثم نسخ الجدول مفلتراً الى الشيت المعنية (لهذا السبب انا طلبت الملف) شيء يشبه هذا الكود Option Explicit Sub filter_Please() Dim arr, Element Dim Rg As Range Set Rg = ActiveSheet.Range("A4").CurrentRegion arr = Array("كهرباء", "ميكانيكا", "نجارة أثاث", _ "زخرفة", "صحي", "إنشاءات", "تشطيبات") For Each Element In arr Rg.AutoFilter , 4, Element Rg.SpecialCells(12).Copy Sheets(Element).Range("A4").PasteSpecial Next ActiveSheet.AutoFilterMode = False End Sub

وعليكم السلام -تم عمل تنسيقات شرطية للمطلوب بهذه المعادلات ... للون الأحمر =COUNTIF($A2:$D2,A2)=2 واللون الأخضر =COUNTIF($A2:$D2,A2)=3 أما اللون البنى فهكذا =COUNTIF($A2:$D2,A2)>=4 التكرار لمرة ومرتين.xlsx

السلام عليكم ورحمة الله وبركاته فكرة بسيطة .. تم استخدام معادلة Vlookup .. واستخدام الرموز .. اكتب في الخلية A2 .. النتيجة تظهر في الخلية D2 .. ممكن ان تطبقها في الملف الخاص بك .. اتمنى ان تعجبك .. clock.xlsm

وعليكم السلام-لك ما طلبت Salary Change1.xlsm

مشاركة مع استاذ علاء MyDataBase100.rar

جرب هذا الكود لعله يفي بالغرض Sub Consolidation() Dim CurrentBook As Workbook Dim WS As Worksheet Set WS = ThisWorkbook.Sheets("sheet1") Dim IndvFiles As FileDialog Dim FileIdx As Long Dim i As Integer, x As Integer Set IndvFiles = Application.FileDialog(msoFileDialogOpen) With IndvFiles .AllowMultiSelect = True .Title = "Multi-select target data files:" .ButtonName = "" .Filters.Clear .Filters.Add ".xlsx files", "*.xlsx" .Show End With Application.DisplayAlerts = False Application.ScreenUpdating = False For FileIdx = 1 To IndvFiles.SelectedItems.Count Set CurrentBook = Workbooks.Open(IndvFiles.SelectedItems(FileIdx)) For Each Sheet In CurrentBook.Sheets Dim LRow1 As Long LRow1 = WS.Range("A" & WS.Rows.Count).End(xlUp).Row Dim LRow2 As Long LRow2 = CurrentBook.ActiveSheet.Range("A" & CurrentBook.ActiveSheet.Rows.Count).End(xlUp).Row Dim ImportRange As Range Set ImportRange = CurrentBook.ActiveSheet.Range("A2:d" & LRow2) ImportRange.Copy WS.Range("A" & LRow1 + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Next CurrentBook.Close False Next FileIdx Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

بالنسبة للتجميع هذاا الملفل للاستاذ الاسطورة ياسر خليل ابو البراء لعله ينفعك يقوم بتجميع الشيتات مع الشكر Collect Data From Multiple CSV Workbooks Mokhtar V1.rar

السلام عليكم ورحمة الله وبركاته تفضل علينا اساتذتنا الكرام جزاهم الله خيرا بالرد الشافى والجواب الكافى ومشاركة منى اتقدم اليكم بهذا المرفق الذى يحدد لك كل بيانات مفاتيح الكيبورد بدون الذهاب والبحث خارج الاكسس ☺ Key Code Constants (☺).rar

انظر المثال المرفق 11 لما يفتح النموذج جرب اضغط على Esc عندي يتم غلق النموذج واذا لم يعمل جرب المثال 12 db11.mdb db12.mdb

الاخ الفاضل ممنون من اهتمامك If KeyCode = 27 Then DoCmd.OpenForm "frm1" End If وضعت هذا الكود فى حدث عند مفتاح لاسفل ولم يعمل عند الضغط على Esc لم يفتح البرنامج المحدد ماذا افعل ارجو افادتى من بحر خبراتكم

الاخ الفاضل ممنون من اهتمامك If KeyCode = 27 Then DoCmd.OpenForm "frm1" End If هذا الكود اكتبة فين فى اى حدث لك خالص الشكر

الارقام نفسها مرتبة داخل جدول .. 8 Arrow to left 53 5 78 N 103 g 9 Tab 54 6 79 O 104 h 13 Enter 55 7 80 P 105 i 27 Esc 56 8 81 Q 106 j 32 Space 57 9 82 R 107 k 33 ! 58 : 83 S 108 l 34 “ 59 ; 84 T 109 m 35 # 60 < 85 U 110 n 36 $ 61 = 86 V 111 o 37 % 62 > 87 W 112 p 38 & 63 ? 88 X 113 q 39 ‘ 64 @ 89 Y 114 r 40 ( 65 A 90 Z 115 s 41 ) 66 B 91 [ 116 t 42 * 67 C 92 \ 117 u 43 + 68 D 93 ] 118 v 44 , 69 E 94 ^ 119 w 45 - 70 F 95 _ 120 x 46 . 71 G 96 ` 121 y 47 / 72 H 97 a 122 z 48 0 73 I 98 b 123 { 49 1 74 J 99 c 124 | 50 2 75 K 100 d 125 } 51 3 76 L 101 e 126 ~ 52 4 77 M 102 f

اتفضل اليك Public Function AllowKeyCode(KeyCode As Integer, Shift As Integer) As Integer If KeyCode = 49 Then DoCmd.OpenForm "جدول البيع", acNormal ElseIf KeyCode = 50 Then DoCmd.OpenForm "ركود", acNormal ElseIf KeyCode = 51 Then DoCmd.OpenReport "جدول الزبائن", acViewPreview End If End Function وفي نموذج عند الضغط على الازرار في كل نماذج اللي تريد ان يعمل لك العملية فتح نماذج والتقارير اكتب Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) KeyCode = AllowKeyCode(KeyCode, Shift) End Sub وعند فتح كل نموذج اللي تريد ان يعمل لك العملية Private Sub Form_Open(Cancel As Integer) Me.KeyPreview = True End Sub واليك قاعدة بيانات بعد تعديل مبيعات نسخة 2003 (2) (1).zip

اتفضل فقط غير في اسماء النماذج في الكود Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = 49 Then DoCmd.OpenForm "جدول البيع", acNormal ElseIf KeyCode = 50 Then DoCmd.OpenForm "ركود", acNormal ElseIf KeyCode = 51 Then DoCmd.OpenReport "جدول الزبائن", acViewPreview End If End Sub Private Sub Form_Open(Cancel As Integer) Me.KeyPreview = True End Sub مبيعات نسخة 2003 (2) (1).zip

السلام عليكم ورحمة الله وبركاته بارك الله لكم جميعا ربما يفيدك هذا المثال المصنوع على عجالة للتعرف على أكواد المفاتيح ascii & ceycode وفتح نموذج عند الضغط على مفتاح معين open form by keys.rar

شكرا للجميع وخاصة للاخ عبدالله المجرب وآسف على رفع الملف بهذه الطريقة شكرا لكم جميعا في المرات القادمة سوف ارفع الملف بدون باسوورد إن شاء الله

حياك الله اخي نور والشكر لصاحب الملف

هذا الملف البسيط تم انتاجة باستخدام بعض الدوال وهو يحسب عمرك اليوم وكذلك يوم مولدك وما يقابل تاريخ ميلادك بالهجري كما يحسب سن التقاعد للمعاش على حسب السن الافتراضي للمعاش في بلدك ___________________________________________________________.rar

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته اود ان اشارك معكم بهذه المشاركة المتواضعة حيث انني استفدت كثير من هذا المنتدى جزاكم الله الف خير المشاركة عبارة عن برنامج لحساب العمر بالميلادي والهجري خالي من اي ماكرو وانا قد استشرت اخي في الله علي السحيب حول هذا البرنامج حيث انه قد قدم اليكم من سابق بمثل فكرة هذا البرنامج فاشار الي ان اطرحه في المنتدى لن اطول عليكم ودمتم في حفظ الله ورعايته اخوكم / خبور ___________________________________________.rar