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

السلام عليكم ورحمة الله وبركاته كما سبق ووعدتكم بفيديوهات يومية ان شاء الله تعليمية مفيدة رابط الفيديو الاول على منتدى اوفيسنا >>>> http://www.officena.net/ib/index.php?showtopic=56480 إليكم الجزء الثاني من الدالة offset وكيفية انشاء نطاقات ديناميكية والاستفادة منها في المعادلات

السلام عليكم الشكر واصل للاخ حسام عيسى ....حفظه الله الكود موجود في موديل الورقة Search Private Sub Worksheet_Change(ByVal Target As Range) If Not Target.Address = Range("C2").Address Then Exit Sub '''''''''''''''''' Dim Lr As Long, i As Long, R As Long Dim txt Range("A6:F25").ClearContents txt = Trim(Target) If Len(txt) < 3 Then Exit Sub With Sheets("Data") Lr = .Cells(.Rows.Count, "A").End(xlUp).Row For i = Lr To 2 Step -1 If txt = CStr(.Cells(i, "A")) Or txt = CStr(.Cells(i, "B")) Or InStr(CStr(.Cells(i, "C")), txt) Then Cells(R + 6, "A").Resize(1, 3).Value = .Cells(i, "A").Resize(1, 3).Value Cells(R + 6, "D").Resize(1, 2).Value = .Cells(i, "E").Resize(1, 2).Value Cells(R + 6, "F").Value = .Cells(i, "H").Value R = R + 1 If R = 20 Then Exit For End If Next End With End Sub المرفق 2010 Search++.rar تحياتي

السلام عليكم لو بحثت في منتدانا لوجدت الكثير من هذا واحسن عموما تم تعديل الكود بما يتناسب لطلبك بدون استخدام اي معادلة حيث يقوم الكود بايجاد آخر صف Sub TestCopyFromClosedWB() Dim wb As Workbook Dim rngTarget As Range Dim strSourceWB As String, strSourceWS As String Dim Lr As Long ' اسم الملف الذي تريد الاستيراد منه strSourceWB = ThisWorkbook.Path & "\Book1.xls" ' اسم الورقة مكان الاستيراد strSourceWS = "Sheet1" ' خلية اللصق Set rngTarget = Range("B2") Application.ScreenUpdating = False On Error Resume Next Set wb = Workbooks.Open(strSourceWB, True, True) On Error GoTo 0 If Not wb Is Nothing Then On Error Resume Next With wb.Worksheets(strSourceWS) ' آخر صف في العمود بي في ورقة الاستيراد Lr = .Cells(.Rows.Count, "B").End(xlUp).Row .Range("B2:K" & Lr).Copy rngTarget End With On Error GoTo 0 wb.Close False End If Application.ScreenUpdating = True Set wb = Nothing: Set rngTarget = Nothing End Sub المرفق 2003 Get Data From Same Path.rar تحياتي

للمهتمين بالاكسيل خصوصا المحاسبين والموارد البشرية انا عملت ملف صغير على الاكسيل يستخرج المعلومات التالية من الرقم القومي معادلات فقط بدون اي اكواد النوع : ذكر ام انثى تاريخ الميلاد محافظة الميلاد وانا حاضر لشرح المعادلات المستخدمه واطمع الا تحرموني من تصويباتكم الرقم القومي.zip

المعذرة يعلم الله أننى فى حالة لا يناسبها كتابة الأكواد و الله المستعان تم التصحيح saeyd4.rar

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

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

اسف نسيت ارفاق الملف data.zip

السلام عليكم أخي العزيز ضع الكود التالي في أي ملف إكسل علي الجهاز وسوف يفعل ماتريد Sub pdf_Move() Dim myFile As String pt = "c:\A\" myFile = Dir(pt) Do While myFile <> "" If Right(myFile, 4) = ".pdf" Then Name "c:\A\" & myFile As "d:\A\" & myFile myFile = Dir() Loop End Sub

أخى الكريم الأستاذ // صلاح الصغير ان شاء الرحمن عندما أنتهى من كامل الدروس سأرفق ملف مجمع به كامل الدروس لأنى ما زلت بالجزء الأول الأساسيات وكيف نطبقها وكل جزء سأرفقه ان شاء الرحمن كاملا بعد الانتهاء منه والله المستعان وتقبل منى وافر الاحترام والتقدير

Sub Tarheel() Dim i As Integer, x As Integer Dim lr As Integer, y As Integer lr = [b10000].End(xlUp).Row Sheets("ناجحون").Range("a9:ho1000").ClearContents Sheets("راسبون").Range("a9:ho1000").ClearContents Application.ScreenUpdating = False x = 9: y = 9 For i = 9 To lr If Cells(i, 3).Value = "ناجح" And Cells(i, 4) <> " " Then Range("a" & i).Resize(1, 223).Copy Sheets("ناجحون").Range("a" & x).PasteSpecial xlPasteValues Application.CutCopyMode = False x = x + 1 ElseIf Cells(i, 3).Value = "له دور ثان" And Cells(i, 4) <> " " Then Range("a" & i).Resize(1, 223).Copy Sheets("راسبون").Range("a" & y).PasteSpecial xlPasteValues Application.CutCopyMode = False y = y + 1 End If Next i MsgBox "تم بحمد الله فصل الناجحين والراسبين فى كشوف منفصلة", vbOKOnly, "ترحيل الناجحون والراسبون" Application.ScreenUpdating = True End Sub بداية الكود Sub Tarheel() السطور التالية خاصة بتعيين متغيرات لتخزين البيانات من نوع أرقام صحيحة Integer Dim i As Integer, x As Integer Dim lr As Integer, y As Integer السطر التالى لتحديد اخر صف يحتوى على بيانات lr = [b10000].End(xlUp).Row السطرين التاليين لمسح بيانات صفحة ناجحون وراسبون قبل نسخ البيانات اليهما Sheets("ناجحون").Range("a9:ho1000").ClearContents Sheets("راسبون").Range("a9:ho1000").ClearContents السطر التالى يعمل على ايقاف اهتزاز الشاشة ( لتسريع الكود ) Application.ScreenUpdating = False السطر التالى يعطى قيمة للمتغيرين x و y وهى تساوى 9 ( أول صف يتم فيه لصق البيانات المنسوخة فى صفحة ( ناجحون ) وصفحة ( راسبون ) x = 9: y = 9 السطر التالى بداية حلقة تكرارية تبدأ من الصف التاسع الى lr ( اخر صف يحتوى على بيانات ) For i = 9 To lr وتنتهى هذه الحلقة التكرارية بالكلمة next السطر التالى يختبر قيمة الخلية المحتوية على نتيجة الطالب If Cells(i, 3).Value = "ناجح" And Cells(i, 4) <> " " Then فاذا كانت تحتوى على كلمة ناجح وخلية اسم الطالب ليست فارغة يقوم بنسخ الصف بالكامل الذى توجد فيه الخلية عن طريق السطر التالى Range("a" & i).Resize(1, 223).Copy السطر التالى يعمل على لصق البيانات المنسوخة الى الصفحة ( ناجحون ) Sheets("ناجحون").Range("a" & x).PasteSpecial xlPasteValues السطر التالى يعمل على ايقاف خاصية النسخ واللصق Application.CutCopyMode = False السطر التالى يزيد قيمة المتغير x بمقدار واحد x = x + 1 الجزء الباقى من الكود تكرار الخطوات السابقة ولكن مع الراسب السطر التالى خاص باظهار رسالة توضح اكتمال عملية فصل الناجحون والراسبون MsgBox "تم بحمد الله فصل الناجحين والراسبين فى كشوف منفصلة", vbOKOnly, "ترحيل الناجحون والراسبون" السطر التالى يعيد مرة اخرى خاصية اهتزاز الشاشة Application.ScreenUpdating = True نهاية الكود End Sub الشرح لاخيكم / رجب جاويش