طارق محمود قام بنشر أغسطس 5, 2012 مشاركة قام بنشر أغسطس 5, 2012 السلام عليكم سألني أحد الإخوة عن التعديل في الكود التالي مع الشرح السؤال "المطلوب تعديل بسيط فى الكود بحيث ترحيل اعمده معينه هنااا فى هذا الكود بيرحل 15 عمود كلهم يعنى بيرحل الشيت كله لكن انا طلبى انه يرحل اعمده معينه انا اللى اختارها بنفسى ويا ريت تكون طريقه الشرح والتوضيح " Sub ahmed() Application.ScreenUpdating = False Dim sh As Worksheet For Each sh In ThisWorkbook.Worksheets For r = 8 To 300 If sh.Name = "Sheet1" Then GoTo 2 If Cells(r, 5).Value <> Empty Then If Cells(r, 5).Value = sh.Name Then Range(Cells(r, 1), Cells(r, 13)).Copy QQ = sh.Cells(1000, 1).End(xlUp).Row + 1 sh.Range("a" & QQ).PasteSpecial xlPasteValues End If End If Next 2 Next Application.CutCopyMode = False Application.ScreenUpdating = True End Sub رابط هذا التعليق شارك More sharing options...
طارق محمود قام بنشر أغسطس 5, 2012 الكاتب مشاركة قام بنشر أغسطس 5, 2012 وقد فضلت ان تكون الإجابة هنا لتعم الفائدة مرفق ملف به الكود والشرح السطر المراد التعديل به هو السطر التاسع ، لون برتقالي / بني Code_Explain3.rar رابط هذا التعليق شارك More sharing options...
طارق محمود قام بنشر أغسطس 5, 2012 الكاتب مشاركة قام بنشر أغسطس 5, 2012 السطر المراد التعديل به Range(Cells(r, 1), Cells(r, 13)).Copy مثلا لو أردنا النسخ من العمود 3 إلي العمود 7 فسيكون السطر كالتالي Range(Cells(r, 3), Cells(r, 7)).Copy أما إذا كان المجال المنسوخ غير متصل مثلا المجال من العمود 2 إلي العمود 4 بالإضافة للمجال من العمود 6 إلي العمود 7 بالإضافة للمجال من العمود 9 إلي العمود 11 فسيكون السطر كالتالي Union(Range(Cells(r, 2), Cells(r, 4)), Range(Cells(r, 6), Cells(r, 7)), Range(Cells(r, 9), Cells(r, 11))).Copy رابط هذا التعليق شارك More sharing options...
احمد حجازى قام بنشر أغسطس 8, 2012 مشاركة قام بنشر أغسطس 8, 2012 هذا هو المرفق ويا ريت تكون فهمت مقصدى يا هندسهBook1.rar رابط هذا التعليق شارك More sharing options...
طارق محمود قام بنشر أغسطس 8, 2012 الكاتب مشاركة قام بنشر أغسطس 8, 2012 السلام عليكم أخي العزيز سهل إن شاء الله ولكن أرجو رفع الملف كاملا ، حتي لايضيع وقت في عمل جهد سبق أن تم من قبل أي أنني أريد الورقتين الورقة المرحل منها والتي أرسلتها أنت في مشاركتك السابقة وكذلك الوقة المرحل إليها ليتم عمل المطلوب حسب الشكل المراد رابط هذا التعليق شارك More sharing options...
احمد حجازى قام بنشر أغسطس 11, 2012 مشاركة قام بنشر أغسطس 11, 2012 حضرتك اعتبره ورقه عمل جديده لان خبره حضرتك هتفرق كتير بمراحل بمعنى انى طالب من حضرتك تعملى السيتم اللى شرحته لحضرتك ف الورقه دى وللك جزيل الشكر بجد وهستنى رد حضرتك اعتبر الكود السابق الى عملته كان لم يكن وان شا الله مستنى مجهود حضرتك الرائع فى الورقه دى .وربنا يجزيك خيييير بجد ........ رابط هذا التعليق شارك More sharing options...
عبدالله المجرب قام بنشر أغسطس 12, 2012 مشاركة قام بنشر أغسطس 12, 2012 بارك الله استاذ طارق وخواتيم مباركة رابط هذا التعليق شارك More sharing options...
طارق محمود قام بنشر أغسطس 13, 2012 الكاتب مشاركة قام بنشر أغسطس 13, 2012 السلام عليكم أخي / عبد الله تقبل الله منا ومنكم صالح الأعمال وجزاك الله كل الخير علي جهدك الدؤوب بالمنتدي رابط هذا التعليق شارك More sharing options...
طارق محمود قام بنشر أغسطس 13, 2012 الكاتب مشاركة قام بنشر أغسطس 13, 2012 السلام عليكم أخي / أحمد حجازي مرور سريع علي الحل وشرح للكود قبل أن تحمل الملف تم إنشاء ورقة إسمها Sample كنموذج لشكل التقرير الذي تريده تم إخفاء هذه الورقة Sample فلن تراها إلا لو أظهرتها تم إضافة كود في حدث الورقة (يتحسس التغيير بالورقة) أي يتم تحفيز عمل الكود أوتوماتيكيا إذا تم أي تغيير في الورقة Sheet1 بناءا علي الخطوات التالية إذا تم تغيير في عمود غير العمود D الذي به إسم الشركة فلن يجري أي خطوات إذا تم التغيير في العمود D فسوف يمرعلي جميع صفوف الورقة من الصف 2 إلي آخر صف به بيانات بالعمود D ثم يقوم بعمل المراجعة التالية قبل خطوات الترحيل (.......) اذا كان موجود بالعمود N كلمة OK فهذا يعني أن هذا الصف تم ترحيله من قبل فيتجاوزه للي بعده (.......) اذا كان عدد البيانات بالأعمدة A:D لاتساوي 4 أولايوجد بيان واحد في الدائن والمدين فهذا يعني أن بيانات هذا الصف ناقصة فيتجاوزه أيضا للي بعده بعد إنهاء المراجعات السابقة ، يبدأ الترحيل إذا كان الملف يحتوي علي ورقة بإسم الشركة الموجودة بالعمود D فيبدأ الترحيل وإلا يكون ورقة جديدة بنفس الإسم (وهنا يتم إظهار الورقة Sample ليستعملها ثم يخفيها) والآن أتركك مع الكود والملف بالمرفق Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column <> 4 Then Exit Sub LastR = [D10000].End(xlUp).Row Application.ScreenUpdating = False For r = 2 To LastR If Cells(r, "N") = "OK" Then GoTo 10 If WorksheetFunction.CountA(Range("A" & r & ":D" & r)) < 4 Or _ WorksheetFunction.Count(Range("G" & r & ":H" & r)) <> 1 Then GoTo 10 nm = Cells(r, "D") For ws = 1 To Sheets.Count If Sheets(ws).Name = nm Then GoTo 5 Next ws Sheets("Sample").Visible = True Sheets("Sample").Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = nm Range("B1").Value = nm Sheets("Sample").Visible = False Sheets("Sheet1").Activate 5 ' Tarheel rr = Sheets(nm).[A10000].End(xlUp).Row + 1 Cells(r, "N") = "OK" Union(Range("A" & r & ":C" & r), Range("G" & r & ":H" & r)).Copy (Sheets(nm).Cells(rr, 1)) 10 Next r Application.ScreenUpdating = True End Sub Code_Explain4.rar رابط هذا التعليق شارك More sharing options...
أبو أنس حاجب قام بنشر أغسطس 13, 2012 مشاركة قام بنشر أغسطس 13, 2012 السلام عليكم ورحمة الله وبركاته أستاذي وسيدي الفاضل طارق محمود حفظك الله وأكرم مدخلك في الفردوس الأعلى خواتم مباركة وبلغك الله ليلة قدره تقبل الله منا ومنكم الصيام والقيام وصالح الأعمال ... رضي ربي عنك وجعل دعوتك لا ترد ورزقك لا يعد وباب فر دوس جنة الله لا يسد . أصلح الله لك ذريتك من بعدك إلى يوم الدين. أبو أنس ناصر حاجب رابط هذا التعليق شارك More sharing options...
طارق محمود قام بنشر أغسطس 15, 2012 الكاتب مشاركة قام بنشر أغسطس 15, 2012 السلام عليكم ولك مثل دعاؤك وزيادة أخي الحبيب / أبا أنس رابط هذا التعليق شارك More sharing options...
إبراهيم ابوليله قام بنشر أغسطس 15, 2012 مشاركة قام بنشر أغسطس 15, 2012 الاخ طارق كود رائع جدا واعتقد ان جميع اخوانى سوف يستفيدون منه ان شاء الله ولكن لى طلب بسيط هل ممكن حضرتك تتفضل بعمل اجمالى للمدين والدائن اسفل الاعمده رابط هذا التعليق شارك More sharing options...
طارق محمود قام بنشر أغسطس 15, 2012 الكاتب مشاركة قام بنشر أغسطس 15, 2012 السلام عليكم أخي العزيز / إبراهيم الطلب بسيط إن شاء الله ولكن لن يكون أسفل الأعمدة ، بل أعلاها لو تتبعت الشرح السابق تجد أنك ممكن عمل ذلك في الورقة Sample حيث ينسخ منها الكود باقي الورقات تفضل الملف وبه التعديل Code_Explain5.rar رابط هذا التعليق شارك More sharing options...
إبراهيم ابوليله قام بنشر أغسطس 15, 2012 مشاركة قام بنشر أغسطس 15, 2012 الاخ طارق فكره جميله بارك الله فيك رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.