رجب جاويش

أخى الفاضل / أكرم جلال كل عام وأنتم بخير اليك الملف بعد تعديل الخطأ وهو خطأ بسيط حيث أن المتغير ws لم يكن معرفا فإما يتم تعريفة على أنه Activesheet أو يتم استبدالة بالكلمة نفسها Activesheet وهو ما قمت بعمله فيكون السطر كالتالى ActiveSheet.Unprotect ونفس الشئ عند ارجاع الحماية مرة أخرى ActiveSheet.protect تعديل.rar

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

أخى الفاضل جرب هذا الكود Sub Ragab() Dim test As New FileSystemObject Dim test_Folder As Folder Dim test_File As File '===================================================== LR = Cells(Rows.Count, 1).End(xlUp).Row Set test_Folder = test.GetFolder(ThisWorkbook.Path) '===================================================== For Each test_File In test_Folder.Files For i = 2 To LR If test_File.Name <> ThisWorkbook.Name Then If test_File.Name = Cells(i, 1) & ".xls" Then test_File.Name = Replace(test_File.Name, test_File.Name, Cells(i, 2) & ".xls") End If End If Next i Next test_File Set test = Nothing End Sub ولكى يعمل الكود نفذ الآتى لمرة واحدة فقط ادخل على محرر الأكواد ALT + F11 ثم من قائمة Tools نختار References ثم نضع علامة صح أمام الإختيار Microsoft Scripting Runtime New.rar

كل عام وأنتم بخير تقبل الله صيامكم وقيامكم وأعاده الله علينا وعليكم وعلى الأمة الاسلامية بالخير واليمن والبركات

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

بعد اذن أخى الحبيب محمود جرب أخى هذا الكود فى حدث الصفحةوهو يغير ال Comment تلقائيا عن أى تغيير فى الخلايا من K11 الى L17 وهى خلايا الصادر والوارد Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("K11:L17")) Is Nothing Then With Range("F6").Comment .Text Text:="مجموع الوارد:" & " " & [k18] & Chr(10) & "مجموع الصادر:" & " " & [L18] End With End If End Sub comment1.rar

أخى الفاضل أى معلومة أنا تعلمتها عن الأكواد كانت من هذا المنتدى وأساتذته الكرام ولكى تبدأ بداية صحيحة عن الأكواد عليك بهذا الرابط http://www.officena.net/ib/index.php?showtopic=39323 فهو يحتوى على دورة متكاملة عن الاكواد وكيفية التعامل معها وكل عام وانتم بخير

أخى الفاضل السطر التالى LR = Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1 وظيفته ايجاد رقم الصف لأول خليه فارغة ( جاهزه لادخال بيانات ) فى sheet1 فى العمود الأول A السطر التالى Sheets("sheet1").Cells(LR, 1).Value = UserForm2.TextBox1.Value يجعل قيمة التكست بوكس 1 الموجود فى اليوزرفورم 2 توضع فى الخلية الفارغة التى تم تجهيز رقمها فى الخطوة السابقة السطر التالى UserForm2.TextBox1.Value = "" يقوم بمسح محتويات التكست بوكس بعد الادخال لاستقبال أى نص جديد

تفضل أخى Book1.rar

تفضل أخى هذه التعديلات المطلوبة أرجو التجربة وابلاغى بالنتيجة بدايه 2.rar

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

تفضل أخى ولكن اعذرنى فانه بسبب كثرة البيانات فان الكود يستغرق حوالى 15 ثانية وأستسمح أستاذى الحبيب / عبد الله باقشير فى استعارة الفورم الخاص بشريط التحديث تعديل كود3.rar

أخى الحبيب / محمود الله يجعل عيدك ( مبارك) وايامك ( تبارك) وجنة الخلد (دارك) تقبل الله طاعتك واتم بالعيد فرحتك واقر عينك بنصر امتك

أخى الحبيب / محمود يطيب لي تهنئتكم بحلول عيد الفطر المبارك سائلا المولى الكريم ان يمن على الجميع بقبول الاعمال والطاعات وان يعيده عليكم وعلى الامة الاسلامية جمعاء بالخير والبركة وان يوفقنا جميعا لمرضاته

أستاذى الحبيب / عبد الله باقشير كل عام وأنتم إلى الله أقرب و على الطاعة أدوم وعن النار أبعد الى كل أعضاء المنتدى الكرام كل عام وأنتم بخير

كل الشكر والتحية لأخى الفاضل / هاني عدلى على مجهوده الرائع ولاثراء الموضوع هذا كود آخر فى حدث الصفحة يتم تشغيلة بمجرد الاختيار من القائمة المنسدلة Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = [E4].Address Then [C8:E1000].ClearContents Dim LR As Integer LR = Sheets("ورقة1").Cells(Rows.Count, 3).End(xlUp).Row For Each cl In Sheets("ورقة1").Range("C3:C" & LR) If cl = [E4] Then cl.Resize(1, 3).Copy Range("C" & [C1000].End(xlUp).Row + 1).PasteSpecial xlPasteValues Application.CutCopyMode = False End If Next End If End Sub توجيه.rar

وهذا تعديل آخر Book2.rar

بارك الله لك في الموهوب ، وشكرت الواهب، وبلغ أشده، ورزقت بره. :fff: اللهم أنبتها نباتاً حسناً، واجعلها قرة عين لكم وبارك لكم فيها وأجعلها من أهل الصلاح والتقوى. :fff: :fff:

أخى الفاضل أرجو التوضيح أكثر

تفضل أخى Book1.rar

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

بعد اذن أخى الفاضل / محمود هذه فكرة أخرى لحذف رقمين من اليسار و3 أرقام من اليمين بمعادلة واحدة =REPLACE(REPLACE(A2;1;2;"");LEN(REPLACE(A2;1;2;""))-2;3;"")+0 مطابقة جدولين.rar

أخى الفاضل جرب هذا الكود وأخبرنى بالنتيجة Sub ragab() Application.ScreenUpdating = False Dim LR1 As Integer, LR2 As Integer, LC As Integer Dim cl As Range, cel As Range, i As Integer '==================================================================== LR1 = Sheets("الصادر").Cells(Rows.Count, "Q").End(xlUp).Row LR2 = Sheets("ماده-وكيل").Cells(Rows.Count, "B").End(xlUp).Row LC = [iv3].End(xlToLeft).Column '==================================================================== Set Rng1 = Range(Cells(3, 4), Cells(3, LC)) Set Rng2 = Sheets("الصادر").Range("Q5:Q" & LR1) '==================================================================== Range("D5:P" & LR2).ClearContents For i = 5 To LR2 For Each cl In Rng1 For Each cel In Rng2 If Cells(i, 2) = cel And cl = cel.Offset(0, 4) Then Cells(i, cl.Column) = Cells(i, cl.Column) + cel.Offset(0, 1) End If Next Next Next Set Rng1 = Nothing Set Rng2 = Nothing Application.ScreenUpdating = True End Sub تعديل كود.rar

لا شكر على واجب أخى الفاضل ومرحبا بك بين اخوانك فى أى وقت وكل عام وأنتم بخير

تفضل أخى copy color.rar