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

عليكم السلام ربما (يدون كود) تجارب نقل جديد.xlsx أو كود Sub test() Dim a Dim i& With Sheets("sheet1") a = .Cells(2, 3).Resize(.Cells(Rows.Count, 3).End(xlUp).Row - 1, 26) End With For i = 1 To UBound(a) a(i, 4) = WorksheetFunction.Ceiling(a(i, 4), 500) Next With Sheets("sheet2") .Cells(2, 1).Resize(UBound(a), 3) = Application.Index(a, Evaluate("row(1:" & UBound(a) & ")"), Array(1, 26, 4)) End With End Sub

Try Sub Test() Const COLTARGET As Long = 3 Dim a, ws As Worksheet, sh As Worksheet, r As Range, i As Long, n As Long With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual End With Set ws = ThisWorkbook.Worksheets("Sheet1") With ws.Range("A3").CurrentRegion Set r = .Offset(, .Columns.Count + 2).Cells(1) .Columns(COLTARGET).AdvancedFilter 2, , r, True a = r.CurrentRegion.Value: r.CurrentRegion.Clear For i = 2 To UBound(a, 1) ws.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count): Set sh = ActiveSheet: sh.Name = a(i, 1) sh.Range("A1").Value = a(i, 1) sh.Range("A3").CurrentRegion.Clear .AutoFilter COLTARGET, a(i, 1) .Copy sh.Range("A4") n = sh.Range("A4").CurrentRegion.Rows.Count - 1 sh.Range("A5").Resize(n).Value = Evaluate("ROW(1:" & n & ")") .AutoFilter Next i End With With Application .Calculation = xlCalculationAutomatic: .EnableEvents = True: .ScreenUpdating = True End With End Sub

وعليكم السلام ورحمة الله تعالى وبركاته Sub Unique_School() Dim rng As Range, cRng As Range Dim Cell As Range, LstRow As Long Dim wsDest As Variant, s As String Dim cUnique As Collection Dim LrDest As Integer, i As Integer Dim WorksheetExists As Boolean Set ws_Data = ThisWorkbook.Sheets("Sheet1") Set rng = ws_Data.Range("C4:C" & ws_Data.Cells(ws_Data.Rows.Count, "C").End(xlUp).Row) Set cUnique = New Collection Application.ScreenUpdating = False Application.DisplayAlerts = False For Each ws In Sheets If ws.Name <> ws_Data.Name Then ws.Delete Next On Error Resume Next For Each Cell In rng.Cells cUnique.Add Cell.Value, CStr(Cell.Value) Next Cell On Error GoTo 0 For Each wsDest In cUnique s = wsDest Sheets.Add(After:=Sheets(Sheets.Count)).Name = wsDest ActiveSheet.DisplayRightToLeft = True With ws_Data LstRow = .Cells(.Rows.Count, "A").End(xlUp).Row .Range("A3").AutoFilter Field:=3, Criteria1:=wsDest Set cRng = .Range("A3:J" & LstRow) cRng.Copy Sheets(s).Range("A3") .Select .Range("A3").AutoFilter End With Next wsDest ws_Data.Activate Application.ScreenUpdating = True End Sub كشف طلاب المدارس 2.xlsm في حالة الرغبة باعادة انشاء تسلسل جديد للصفوف كشف طلاب المدارس 3.xlsm

الف مبروك شخصية تستاهل كل خير

بارك الله لكم جميعا اعضاء ومشرفي هذا المنتدي الكبير ما اعظم عقولكم وما ارقي مساعدتكم ابوحبيبه عبدالله بشير عبدالله lionheart لكم كل تقدير واحترام

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

لا وشكرا .... والعيب عندي انا في تحميل الملف وجزاك الله خيرا ...وعذرا منك

العفو اخي حمل الملف من المرفقات ووافينا بالنتيجة

بالفعل هو ملف الاستاذ/ ابوحبيبة فأنا حملته وطبقت عليه كود حضرتك وبحسب ان الملف واحد عند الاساتذه ...فعذرا منك

@lionheart فكره جميلة لاكن اعتقد انه من الضروري اضافة حذف الاوراق القديمة قبل تنفيذ الكود تفاديا لظهور رسالة خطأ With ws.Range("A3").CurrentRegion اما بالنسبة لهدا السطر في حالة كان هناك اي بيانات اخرى بجانب الجدول (مجرد احتمال) سيتم نسخها كدالك

من خلال التنسيق الشرطي تستطيع تنفيذ ما تردي قمت بتنفيذ طلبك على عمود Arab حل للتقارير متعددة الأعمدة_01.zip

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي اسم المستخدم : admin كلمة المرور : 1989 Option Compare Text Dim f, Rng, MH(), WS_Rng, DataRng Private Sub UserForm_Initialize() DataRng = "Tableau1" WS_Rng = Range(DataRng).Columns.Count MH = Range(DataRng).Resize(, WS_Rng + 1).Value For i = 1 To UBound(MH): MH(i, WS_Rng + 1) = i: Next i Me.ListBox1.List = MH Me.ListBox1.ColumnCount = WS_Rng + 1 Me.ListBox1.ColumnWidths = "70;110;100;100;100" Me.ComboBox1.List = Application.Transpose(Range(DataRng).Offset(-1).Resize(1)) Me.ComboBox1.ListIndex = 0 Me.B.Caption = "فلترة ب:" & Me.ComboBox1 Set d = CreateObject("scripting.dictionary") For i = 1 To UBound(MH) d(MH(i, 1)) = "" Next i WSdata = d.keys Me.ComboBox2.List = WSdata Sht = Application.Transpose(Range(DataRng).Offset(-1).Resize(1)) For i = 1 To WS_Rng Me("label" & i) = Sht(i, 1) Next i For i = WS_Rng + 1 To 6 Me("label" & i).Visible = False: Me("TextBox" & i).Visible = False Next i Me.ComboBox2 = "*" T_resultat = "عدد الموظفين" & "/" & ListBox1.ListCount + 0 Count = ListBox1.ListCount End Sub '''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Combobox1_click() Me.ListBox1.List = MH Me.B.Caption = "فلترة ب:" & Me.ComboBox1 Me.T.Caption = "بحث ب:" & Me.ComboBox1 Set Titre = Range(DataRng).Offset(-1).Resize(1) colFiltre = Application.Match(Me.ComboBox1, Titre, 0) Set d = CreateObject("scripting.dictionary") For i = 1 To UBound(MH) d(MH(i, colFiltre)) = "" Next i WSdata = d.keys Me.ComboBox2.List = WSdata Me.ComboBox2 = Empty End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub TextBoxRech_Change() On Error Resume Next WSdest = Me.ComboBox1.ListIndex + 1 clé = "*" & Me.TextBoxRech & "*": n = 0 Dim Tbl() For i = 1 To UBound(MH) If MH(i, WSdest) Like clé Then n = n + 1: ReDim Preserve Tbl(1 To UBound(MH, 2), 1 To n) For k = 1 To UBound(MH, 2): Tbl(k, n) = MH(i, k): Next k End If Next i If n > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.clear End Sub منظومة-الشؤون-الادارية.xlsm

تفضل ترجمة.accdb

لم أفهم جيدا المطلوب... أنظر الملف المرفق فيه تعديل حسب ما فهمت... ترتيب.xlsb

شكرا اخي الفاضل على اهتمامك ... جزاك الله خيرا

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

السلام عليكم -يمكنك ذلك بإستخدام هذه المعادلة داخل Data Validation =YEAR($C2)<=2000 عدم قبول ادخال تاريخ قبل سنة معينة.xlsx

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

جزاء الله خيرا اخي ... lionheart جزاء الله خيرا اخي ...عبدالله بشير عبدالله ما شاء الله ... الملف فعلا شغال ويستدعي البيانات المطلوبة . لكن هناك ملحوظة لو ان الاسماء اكثر من 20 . عند الضغط على السهم لأعلى _ بجوار خانة المواد _ لا يعطيني الاسماء الباقية هل من طريقة للحصول على باقي الاسماء عند الضغط على السهم لأعلى

شكرا أستاذ كريم 🌹 شكر أستاذ حسونة🌹

السلام عليكم lionheart اعتقد ان صاحب الملف كما قال انه لم يعطى له نتائج بسبب عدم اضافة الكود Get_Data_By_Subject الى زر او الى صفحةLagna فيكون كالاتي Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$L$3" Then Application.ScreenUpdating = False Range("B9:I28").ClearContents Application.ScreenUpdating = True End If Get_Data_By_Subject End Sub وهذا ملف كامل به كود استاذنا lionheart وقمت بالتجربة فتم استدعاء الطلبة حسب المادة حقيقة سرعة ابداع اتقان زادك الله رفعة وعلما استاذنا الفاضل الملف قوائم لجان الدور الثاني - Copy.xlsb

وعليكم السلام ورحمة الله بركاته الإجرائان التاليان للتشفير، وفك التشفير Sub EncodeBinaryFileToBase64(BinaryFileName As String, Base64FileName As String) Dim XML, Node, InputFile, OutputFile, XPath Dim FSO, Output, InStream, ReadBytes, Base64Encode XPath = CurrentProject.Path & "\" InputFile = XPath & BinaryFileName OutputFile = XPath & Base64FileName Set InStream = CreateObject("ADODB.Stream") InStream.Open InStream.Type = 1 'TypeBinary InStream.LoadFromFile (InputFile) ReadBytes = InStream.Read() InStream.Close Set XML = CreateObject("Msxml2.DOMDocument") Set Node = XML.createElement("base64") Node.DataType = "bin.base64" Node.nodeTypedValue = ReadBytes Base64Encode = Node.Text Set FSO = CreateObject("Scripting.Filesystemobject") Set Output = FSO.CreateTextFile(OutputFile, 1) Output.Write Base64Encode Output.Close End Sub Sub DecodeBase64ToBinaryFile(Base64FileName As String, BinaryFileName As String) Dim InputFile, OutputFile, XPath, Contents Dim FSO, XML, Node, BinaryStream, XInput XPath = CurrentProject.Path & "\" InputFile = XPath & Base64FileName OutputFile = XPath & BinaryFileName Set FSO = CreateObject("Scripting.Filesystemobject") Set XInput = FSO.OpenTextFile(InputFile, 1) Contents = XInput.ReadAll() XInput.Close Set XML = CreateObject("Msxml2.DOMDocument") Set Node = XML.createElement("base64") Node.DataType = "bin.base64" Node.Text = Contents Set BinaryStream = CreateObject("ADODB.Stream") BinaryStream.Type = 1 'adTypeBinary BinaryStream.Open BinaryStream.Write Node.nodeTypedValue BinaryStream.SaveToFile OutputFile End Sub Base64.accdb

رائعة النابغه ياسر خليل في الترحيل بالمصفوفات ترحيل أعمدة غير متجاورة لأعمدة غير متجاورة باستخدام المصفوفات (كود حصري) https://youtu.be/ndC28IqkkBw ** من يريد دعمي فليقم بالاشتراك في القناة وعمل لايك للفيديوهات ============= رابط الملف https://www.file-upload.com/ablfo2nqpekx

********************************* '=========================== 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو استدعاء بشرط 'وكذلك الاستدعاء بدون شرط بسطر برمجي جديد 'وقد تم التنويه داخل الكود عن السطر المسئول 'تم هذا الكود في 15/2/2017 '================== Sub استدعاء_بمعيار1() Dim arr As Variant Dim temp As Variant Dim cr As Variant Dim lr As Long Dim i As Long Dim j As Long Dim c As Long Dim ws As Worksheet Dim sh As Worksheet Dim myArray, targt, targt1 Set Main = Sheets("المصدر") Set sh = Sheets("Sheet2") targt = "ذكر*" 'خلية البحث '= = = = = = = = = = = = ' شيت الهدف والمدى المطلوب مسحه sh.Range("B7:AE1000").ClearContents ' عدد الصفوف في ورقة المصدر lr = Main.Cells(Rows.Count, 1).End(xlUp).Row 'متغير اسم ورقة المصدرومدى البيانات بها arr = Main.Range("A7:EF" & lr).Value ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2)) 'ارقام الاعمده المطلوب نقلها cr = Array(2, 3, 7, 8, 9, 11, 5, 135) j = 1 For i = LBound(arr, 1) To UBound(arr, 1) '================== 'اذا أردت ان يستدعي بيانات بشرط 'ماعليك الا ان تجعل السطر البرمجي الموجود 'اسفل هذا السطر يعمل '================== 'رقم عمود الذي سيتم البحث فيه If arr(i, 5) Like targt & "*" Then '================== temp(j, 1) = j For c = LBound(cr) To UBound(cr) temp(j, c + 2) = arr(i, cr(c)) Next c j = j + 1 '================== End If '================== Next i With sh 'خليه بدايه اللصق في شيت الهدف .Range("B7").Resize(j - 1, UBound(temp, 2)).Value = temp 'سطر لمسح التسطير .Range("B7:AJ" & Rows.Count).Borders.Value = 0 'سطر لاضافة التسطير .Range("B7:AJ" & .Cells(Rows.Count, 2).End(xlUp).Row).Borders.Value = 1 End With End Sub '=========================== 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو استدعاء بشرط 'تم هذا الكود في 15/2/2017 '================== Sub استدعاء_بدون_شرط() Dim arr As Variant Dim temp As Variant Dim cr As Variant Dim lr As Long Dim i As Long Dim j As Long Dim c As Long Dim ws As Worksheet Dim sh As Worksheet Set ws = Sheets("المصدر") Set sh = Sheets("Sheet2") '= = = = = = = = = = = = ' شيت الهدف والمدى المطلوب مسحه sh.Range("B7:AJ10000").ClearContents ' اسم ورقة المصدر lr = ws.Cells(Rows.Count, 1).End(xlUp).Row 'متغير اسم ورقة المصدرومدى البيانات بها arr = ws.Range("A7:EF" & lr).Value ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2)) 'ارقام الاعمده المطلوب نقلها cr = Array(2, 3, 7, 8, 9, 11, 5, 135) j = 1 For i = LBound(arr, 1) To UBound(arr, 1) ' المعيار او الشرط الذي نبحث به ورقم عمود المعيار ' If arr(i, 135) Like "*" & "نا*" & "*" Then temp(j, 1) = j For c = LBound(cr) To UBound(cr) temp(j, c + 2) = arr(i, cr(c)) Next c j = j + 1 ' End If Next i ' اسم شيت الهدف With sh 'خليه بدايه اللصق في الشيت الهدف .Range("B7").Resize(j - 1, UBound(temp, 2)).Value = temp 'سطر لمسح التسطير .Range("B7:AJ" & Rows.Count).Borders.Value = 0 'سطر لاضافة التسطير .Range("B7:AJ" & .Cells(Rows.Count, 2).End(xlUp).Row).Borders.Value = 1 End With End Sub

أخي العزيز ناصر .. بعد وضع النتائج في نطاق معين ..على سبيل المثال إذا كانت النتائج تبدأ في الخلية G1 .. يمكنك الاعتماد على النطاق بالشكل التالي الإشارة لورقة العمل + أول خلية بالنطاق أو أي خلية داخل النطاق الذي يحتوي النتائج ثم استخدام خاصية CurrentRegion بهذا الشكل With Sheets("Sheet1").Range("G1").CurrentRegion .............. End With مكان النقاط في الكود يوضع سطر بسيط جداً للتسطير بهذا الشكل .Borders.Value=1 ولإلغاء التسطير استبدل الرقم 1 في السطر السابق بالقيمة صفر .. أرجو أن يفيدك الرد إن شاء الله

الترحيل بشرط معين في عمود معين بسهوله ويسر بالمصفوفات للنابغه ياسر خليل Option Explicit 'هذا الكود للمحترم النابغه ياسر خليل 'الهدف من الكود هو ترحيل بشرط 'تم هذا الكود في 15/2/2017 Sub UsingArrays() Dim arr As Variant Dim temp As Variant Dim lr As Long Dim i As Long Dim j As Long Dim c As Long 'متغير اسم ورقة المصدر lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 'متغير اسم ورقة المصدرومدى البيانات بها arr = Sheets("Sheet1").Range("A2:C" & lr).Value ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2)) j = 1 For i = LBound(arr, 1) To UBound(arr, 1) ' المعيار او الشرط الذي نبحث به If arr(i, 3) Like "*" & "P" & "*" Then For c = LBound(arr, 2) To UBound(arr, 2) temp(j, c) = arr(i, c) Next c j = j + 1 End If Next i 'متغير اسم ورقة الهدف واسم الخليه التي سيتم ترحيل العناوين اليها Sheets("Sheet2").Range("E5").Resize(, UBound(temp, 2)).Value = Array("Names", "Marks", "Status") 'متغير اسم ورقة الهدف واسم الخليه التي سيتم الترحيل اليها Sheets("Sheet2").Range("E6").Resize(j - 1, UBound(temp, 2)).Value = temp End Sub