محمد هشام.

ترتيب (4).xlsx

تفضل جرب ربما هدا ما تقصد ترتيب.xlsx

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

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Sub Copysh() Dim SourceSht As Worksheet Set SourceSht = Sheets("sheet1") Application.ScreenUpdating = False Set Closesh = Workbooks.Open(ThisWorkbook.Path & "\تسويات العهد.xlsm", Password:="123") SourceSht.Copy After:=Closesh.Sheets(Closesh.Sheets.Count) 'حدف الاشكال ActiveSheet.Shapes("copy").Delete ActiveSheet.Shapes("Rounded Rectangle 5").Delete ActiveSheet.Shapes("شكل بيضاوي 1").Delete ActiveSheet.Shapes("صورة 5").Delete Closesh.Close SaveChanges:=True Application.ScreenUpdating = True End Sub بنامج تسوية العهدة.xlsm تسويات العهد.xlsm

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

وعليكم السلام ورحمة الله تعالى وبركاته كان من الافضل رفع مثال للنتيجة المطلوبة مع تحديد النطاق المراد حدف الكلمات بداخله .... تفضل اخي يمكنك استخدام الكود التالي لحدف جميع الكلمات والحروف الانجليزية الموجودة في ورقة العمل مع الاحتفاظ بالباقي Sub Remove_specific_Value() Dim A As String * 1 Dim B As String * 1 Dim i As Integer Dim S As String Application.ScreenUpdating = False ' يمكنك الاضافة ما تشاء في السطر التالي 'مثال "),-,_,@,/,.,<,>,;,?,é,;,=,+" Const MH = "a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z, A, B, C, D, E, F, G ,H ,I ,J, K ,L ,M ,N ,O ,P ,Q, R ,S ,T ,U, V, W ,X ,Y, Z" Const MH2 = "" ' كما يمكنك هنا استبدال الحروف المحدوفة بشيئ معين' Range("A1").Resize(Cells.Find(what:="*", SearchOrder:=xlRows, _ SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _ Cells.Find(what:="*", SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, LookIn:=xlValues).Column).Select ' For Each cell In Selection If cell <> "" Then S = cell.Text For i = 1 To Len(MH) A = Mid(MH, i, 1) B = Mid(MH2, i, 1) S = Replace(S, A, B) Next cell.Value = S Debug.Print "celltext "; (cell.Text) End If Next cell Range("A3").Select Application.ScreenUpdating = True End Sub وهدا مثال لطلبك مثال _mh.xlsm

تفضل اخي المشكلة في تحديد نطاق قاعدة البيانات لديك قد تم تعدبلها لحدود 50000 صف بالتوفيق...... 779215434_.xls

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي جرب =PETITE.VALEUR(SI(A$2:A$19<>"الثانوية الإعدادية ابو بكر الصديق";B$2:B$19);LIGNE()-1) نزولا بالمعادلة الى الاسفل وبهده الطريقة يمكنك استخراج أصغر أربع أعداد (او ماتشاء) مع استثناء الأعداد التي هي في نفس الصف لاسم الثانوية الموجودة في الخلية (i2) مثلا =SI($I$2="";"";PETITE.VALEUR(SI(A$2:A$19<>$I$2;B$2:B$19);LIGNE()-1)) ترتيب.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي بالنسبة لطلبك اعتقد ان جواب استادنا الكبير بن علية حاجي يوفي بالغرض لاكن لاثراء الموضوع وتعميم الفائدة للجميع بالمعادلات يمكنك بهده الطريقة =SI(ESTNA(EQUIV("ALI";$S$9:$S$25;0));"غير موجود";"موجود") او =SI(ESTNA(RECHERCHEV("ALI";$S$9:$S$25;1;FAUX));"غير موجود";"موجود") او =SI(ESTNA(EQUIV(A9;$S$9:$S$25;0));"غير موجود";"موجود") ملاحظة: المعادلات تمت كتابتها على اوفيس فرنسي .كما سبق الدكر اتجنب اعادة صيغتها تفاديا للاخطاء .يمكنك تحميل الملف من المرفقات سيتم ترجمتها تلقائيا على جهازك اما بالنسبة للاكواد هناك عدة طرق منها لنفترض انك ترغب ظهور النتيجة في الخلية ("A5") Sub test1() Dim code As String Dim Trouve As Range With Sheets("Sheet1") Set Trouve = .Range("S:S").Find(what:="ALI", LookIn:=xlValues, lookat:=xlWhole) If Trouve Is Nothing Then Range("A5") = " غير موجود" Else Range("A5") = "موجود" End If End With End Sub وبهده الطريقة ادا كانت لك رغبة بالبحث بقيمة خلية معينة ولنفترض انها M4 Sub test2() Dim code As String Dim Trouve As Range With Sheets("Sheet1") ' تحديد العمود ورقم الخلية Set Trouve = .Range("S:S").Find(what:=Range("M4"), LookIn:=xlValues, lookat:=xlWhole) If Trouve Is Nothing Then 'M6 ظهور التنيجة في الخلية Range("M6") = " غير موجود" Else 'في حالة عدم العثور على القيمة Range("M6") = "موجود" End If ''''''''''''''''''''''''''''''''''''''''''' Sub test4() Dim MH As Range Set MH = Range("S9:S25").Find(What:=Range("M4").Value, LookIn:=xlValues, LookAt:=xlWhole) If Not MH Is Nothing Then Range("M6").Value = "موجود" Else Range("M6").Value = " غير موجود" MsgBox " غير موجود" End If End Sub End With End Sub اما في حالة الرغبة في البحث وتنفيد نفس الامر على عدة قيم في نطاق معين يمكنك بهده الطريقة Sub test3() Dim X As Variant Dim Rng As Range 'تحديد نطاق القيم المبحوث عنها ' مثال من الصف 9 الى 13 For i = 9 To 13 'تحديد رقم العمود X = Cells(i, 11) 'تحديد نطاق القيم المبحوث عنها With Sheets("sheet1").Range("S9:S25") Set Rng = .Find(what:=X, After:=.Cells(.Cells.Count), _ LookIn:=xlValues, lookat:=xlWhole, _ SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) If Not Rng Is Nothing Then 'في حالة العثور على القيمة Cells(i, 10).Value = "موجود" Else 'في حالة عدم العثور على القيمة Cells(i, 10).Value = "غير موجود" End If End With Next i End Sub قد تم اضافة الاكواد والمعادلات للملف المرفق بالتوفيق........... التحقق من وجود قيمة معينة.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ...قد تم اضافة جميع الاكواد الى الملف المرفق Sub AutoF_Data() Dim c As Integer Dim MH As String Dim ws1 As Worksheet, ws2 As Worksheet Dim Y As ListObject, Y1 As ListObject, Y2 As ListObject Dim Lastrow As Long Lastrow = Feuil1.Range("H" & Rows.Count).End(xlUp).Row + 1 'خلية شرط معيار الفلترة MH = Sheets("Sheet1").Range("C1").Value If Len(Range("C1").Value) = 0 Then MsgBox "المرجوا ادخال معيار الفلترة" Exit Sub End If 'افراغ النطاق قبل الترحيل Range("H1:K" & Lastrow).Clear 'جدول البيانات Set ws1 = Sheets("Sheet1") 'مكان وضع البيانات المفلترة Set ws2 = Sheets("sheet1") 'في حالة الرغبة في اضافة شيت جديد وترحيل البيانات اليه 'Set ws2 = Sheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)) 'نسخ الى شيت موجود سابقا 'Set ws2 = Sheets("اسم الشيت") ''''''''''''''الجدول 1 Set Y = ws1.ListObjects(1) Application.ScreenUpdating = False 'تحديد عمود معيار الفلترة Y.Range.AutoFilter Field:=2, Criteria1:=MH Y.Range.SpecialCells(xlCellTypeVisible).Copy 'تحديد موضع اللصق ws2.Cells(3, 8).PasteSpecial xlValues Application.CutCopyMode = False '''''''''''''''الجدول 2 Set Y = ws1.ListObjects(3) Y.Range.AutoFilter Field:=2, Criteria1:=MH Y.Range.SpecialCells(xlCellTypeVisible).Copy ws2.Cells(12, 8).PasteSpecial xlValues Application.CutCopyMode = False '''''''''''''''الجدول 3''''''''''''''''''''''' Set Y = ws1.ListObjects(2) Y.Range.AutoFilter Field:=2, Criteria1:=MH Y.Range.SpecialCells(xlCellTypeVisible).Copy ws2.Cells(21, 8).PasteSpecial xlValues Application.CutCopyMode = False '''''''''''''''نسخ رؤؤس الجداول''''''''''''''''' Set Y1 = ws2.ListObjects.Add(SourceType:=xlSrcRange, Source:=ws2.Cells(3, 8).CurrentRegion, xlListObjectHasHeaders:=xlYes) Set Y1 = ws2.ListObjects.Add(SourceType:=xlSrcRange, Source:=ws2.Cells(12, 8).CurrentRegion, xlListObjectHasHeaders:=xlYes) Set Y1 = ws2.ListObjects.Add(SourceType:=xlSrcRange, Source:=ws2.Cells(21, 8).CurrentRegion, xlListObjectHasHeaders:=xlYes) Feuil1.Activate ActiveSheet.ListObjects("Tableau3").Range.AutoFilter Field:=2 ActiveSheet.ListObjects("Tableau2").Range.AutoFilter Field:=2 ActiveSheet.ListObjects("Tableau1").Range.AutoFilter Field:=2 'تنسيقات الجداول Call MH3 Application.ScreenUpdating = True End Sub بالتوفيق تصفية في شيت واحد.xlsm

حاول وضع هدا الكود في حدث الشيت ..... سيتم تغيير تنسيق الخلايا في عمود التاريخ تلقائيا بعد جلب البيانات يمكنك تعديل الكود على حسب النطاق الموجود عندك في الملف الرئيسي Private Sub Worksheet_selectionChange(ByVal Target As Range) If Not Intersect(Target, Range("A10:A1000")) Is Nothing Then Dim lastRow As Long lastRow = Cells.Find("*", [A9], , , xlByRows, xlPrevious).Row Range("A10:A1000" & lastRow).NumberFormat = "dd-mm-yyyy" Range("G2:G4").NumberFormat = "dd-mm-yyyy" End If End Sub وهدا مثال على ملفك لتغيير تنسيق الخلايا بعد جلبها بالمعادلات من شيت اخر بتنسيقات مختلفة. وفلترة التواريخ بدون مشاكل بالتوفيق اظهار نطاق محدد.xlsm

ممكن ترفع الملف

أخي لقد لاحظت ذالك فعلا قبل رفع الملف لاكن المشكلة عندك في تنسيق الخلايا

تفضل جرب اخي Public Sub Filter() Dim rng1 As Long, rng2 As Long rng1 = Range("G2").Value rng2 = Range("G4").Value Range("A9:A1000").AutoFilter Field:=1, _ Criteria1:=">=" & rng1, _ Operator:=xlAnd, _ Criteria2:="<=" & rng2 End Sub اظهار نطاق محدد.xlsm

تفضل اخي @2saad ملاحظة بعد النظرة السريعة لاحظت خلل في اكواد الترحيل والتعديل مع عدم الاشارة الى (TextBox9) داخل الاكواد فورم بحث برقم الجلوس وبه إضافة وتعديل 2وحذف (7).xlsm

تفضل جرب اخي Private Sub Worksheet_SelectionChange(ByVal Target As Range) ActiveSheet.Unprotect Password:="123" Union([C7:C28], [E7:E28], [F17:F28], [H17:H28]).Replace What:="", Replacement:="0" ActiveSheet.Protect Password:="123" End Sub نموذج ساعات 4.xlsm

ادا كنت تقصد جعلها بهده الطريقة يمكنك دالك بتعديل بسيط على المعادلات قم بنسخ المعادلات الى ملفك الرئيسي نموذج ساعات 4.xlsm

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

قم بالغاء الحماية على الخلايا المراد التعديل عليها قبل حماية المصنف او قم برفع ملفك مع توضيح المطلوب

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي Book3_MH.xlsx

اولا ما هي الطريقة التي يتم بها تنزيل البيانات ؟ أما في حالة كانت الأسماء موجودة مسبقا عندك في عمود A مثلا ممكن تختار عمود آخر يتم استخراج فيه الإسم الثلاثي

السلام عليكم ورحمة الله تعالى وبركاته بعد إذن الأستاذ الكبير بن علية حاجي تعديل بسيط على الملف بإضافة التقويم لجميع خلايا عمود التاريخ ربما يفيدك وتقويم آخر مستقل لخلية تاريخ تقديم الطلب . Private Sub Worksheet_selectionChange(ByVal Target As Range) If Not Intersect(Target, Range("B17:B28")) Is Nothing Then Dim UnJour As Date Application.EnableEvents = False Cancel = True UnJour = FormCal.Calendrier If UnJour <> 0 Then Target = Format(UnJour, "mm/dd/yyyy") Else Target = "" End If Selection.Offset(0, 0).Select Application.EnableEvents = True End If Sub ShowCal() Dim myDate As Date myDate = CalendarForm.GetDate(FirstDayOfWeek:=Monday, SaturdayFontColor:=RGB(250, 0, 0), SundayFontColor:=RGB(250, 0, 0)) If myDate > 0 Then Range("M4").Value = myDate End Sub End Sub نموذج ساعات 3.xlsm

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

أخي هو نفس الملف الذي تم الاشتغال عليه أكثر من مرة !!! ليس من المعقول أنك كلما فكرة في إضافة شيء ما نعيد العمل على الملف من البداية . لاننا نهدر ساعة ولربما أكثر لإتمام طلبك ومساعدتك. بحيث تقوم انت بوضعه في الأرشيف وإعادة تصميم ملف مشابه . 1)تم الاشتغال عليه أول مرة بترحيل البيانات من شيت لآخر والبحث والتعديل 2) تم الاشتغال عليه بعد إضافة واجهة لادخال البيانات أمس الآن انت قمت باضافة فورم لنفس المهمة . كان من المفروض أن تأجل رفع الملف حتى تكمل تصميم ملفك وهذا لا يشجعني إلا الاستمرار في اهدار الوقت بدون فائدة بالتوفيق ....