طارق محمود قام بنشر نوفمبر 20, 2011 مشاركة قام بنشر نوفمبر 20, 2011 السلام عليكم تقصد أن النتيجة التي عنوانها نتيجة الطالبة للترحيل للشيت المناسب ستكون بعمود آخر والذي به النتائج مثل: ناجحة ومنقولة ، لها دور ثان ، ....ليس لها حق الإعادة وليكن Y كما فرضت سيتطلب أيضا تعديل صدر الكود لإستخدام عمود بديل في التصفية غير السابق الذي كان X وليكن في أقصي اليسار GX مثلا بدلا من X وعلي ذلك يبدأ الكود بــ rg1 = "Y11:Y" & [Y3000].End(xlUp).Row Range(rg1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("GX11"), Unique:=True Dim sht(9) As String, x(9) As Integer case_NO = [x100].End(xlUp).Row - 11 For i = 1 To case_NO sht(i) = Cells(11 + i, "GX") Next i Range("GX11:GX" & 12 + case_NO).ClearContents إن وجدت صعوبة إرسل لي مثالا به البيانات بالشكل المطلوب رابط هذا التعليق شارك More sharing options...
يوسف عطا قام بنشر نوفمبر 20, 2011 الكاتب مشاركة قام بنشر نوفمبر 20, 2011 شاكر أفضالك مرة أخرى فعلاً حاولت ولم أحقق نتيجة مرضية ولا أعرف ما علاقة عمود GX بالموضوع على العموم مرفق الملف كما أتصوره وتم تبديل العمود U ليكون بديلاً للعمود A ومن تعديلك للكود سأحاول أن أكتشف ما أريد عند المقارنة بين التعديلين تعديل ترحيل.rar رابط هذا التعليق شارك More sharing options...
طارق محمود قام بنشر نوفمبر 20, 2011 مشاركة قام بنشر نوفمبر 20, 2011 السلام عليكم أخي العزيز ولا أعرف ما علاقة عمود GX بالموضوع في أول الكود جزء بعنوان الجزء التالي يحفظ أسماء جميع الحالات الموجودة في العمود الأول لو دققت فيه فهذا الجزء يكون نسخة غير مكررة عن طريق التصفية المتقدمة للعمود الذي به نتائج وكان يضعها مؤقتا في العمود X ثم نلغي هذه القيم بعد حفظ الأسماء في المتغير sht(i) وحيث أنك أخبرتني في ان البيانات ستمتد إلي العمود Y ساعتها عدلت لك الكود للعمود Y ولكن في المرفق البيانات في العمود U وليس العمود Y عموما العمود U رقمه 21 في الشيت وهذا يفسر لك وجود الرقم 21 في الكود بدلا من الرقم 1 في الكود القديم وكذلك عدلت قليلا في الجزء الأخير (ضبط المسلسل في الشيتات التي حدث الترحيل إليها) لكي يتم التعامل مع العمود الذي به المسلسل A وليس B إليك الكود الجديد Sub Tareqتعديل_ترحيل() '============================================= On Error Resume Next Application.ScreenUpdating = False 'الجزء التالي يحفظ أسماء جميع الحالات الموجودة في العمود الأول rg1 = "U11:U" & [U3000].End(xlUp).Row Range(rg1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("GX11"), Unique:=True Dim sht(9) As String, x(9) As Integer case_NO = Cells(1000, 206).End(xlUp).Row - 11 For i = 1 To case_NO sht(i) = Cells(11 + i, "GX") Next i Range("GX11:GX" & 12 + case_NO).ClearContents 'الجزء التالي يمسح فقط المجال المطلوب من الشيتات التي أسماؤها مسجلة في الجزء السابق For sh = 1 To Sheets.Count For i = 1 To case_NO If Sheets(sh).Name = sht(i) Then Sheets(sh).Range("A11:U3000").ClearContents Next i Next sh 'وهناأصل البرنامج For a = 11 To [U3000].End(xlUp).Row If Cells(a, 21) <> "" Then MySheets = Cells(a, 21) Range(Cells(a, 1), Cells(a, 40)).Copy Sheets(MySheets).[A3000].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues End If Next a Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل" ' وهنا تطوير طفيف ليلائم العدد المتغير للحالات For i = 1 To case_NO x(i) = Sheets(sht(i)).[A3000].End(xlUp).Row - 10 mssg = mssg & Chr(10) & x(i) & " " & sht(i) Next i MsgBox (" تم ترحيل عدد" & mssg) Range("a1").Select ' وأخيرا هذا الجزء لضبط المسلسل في الشيتات التي حدث الترحيل إليها For i = 1 To case_NO Sheets(sht(i)).[A11] = 1 rrw = Sheets(sht(i)).[A3000].End(xlUp).Row For Each cc In Sheets(sht(i)).Range("A12:A" & rrw) cc.Value = cc.Offset(-1, 0) + 1 Next cc Next i On Error Resume Next On Error GoTo 0 End Sub والمرفق بعد التعديل تعديل ترحيل3.rar رابط هذا التعليق شارك More sharing options...
الـعيدروس قام بنشر نوفمبر 20, 2011 مشاركة قام بنشر نوفمبر 20, 2011 السلام عليكم الاستاذ القدير طارق محمود كود جميل وشرح ولااروع جزاك الله خير وجعله في ميزان حسناتك رابط هذا التعليق شارك More sharing options...
يوسف عطا قام بنشر نوفمبر 20, 2011 الكاتب مشاركة قام بنشر نوفمبر 20, 2011 ربنا يزيدك من العلم يا استاذ طارق ويجازيك خيراً ويجعل أعمالك فى موازين حسناتك رابط هذا التعليق شارك More sharing options...
طارق محمود قام بنشر نوفمبر 21, 2011 مشاركة قام بنشر نوفمبر 21, 2011 الحمد لله والشكر لله رابط هذا التعليق شارك More sharing options...
mhrrd قام بنشر نوفمبر 21, 2011 مشاركة قام بنشر نوفمبر 21, 2011 اكثر الله من خيرك استاذ طارق ** لو سمحت طبق هذه التغييرات على الكود الاصلي الخاص بالاستاذ خبور لانني ارى امامي فيه الاعمده التي اود ان اضيفها او ازيلها بعد اذنك جزاك الله خيرا رابط هذا التعليق شارك More sharing options...
طارق محمود قام بنشر نوفمبر 21, 2011 مشاركة قام بنشر نوفمبر 21, 2011 السلام عليكم لم أفهم ، ماذا تعني؟ الكود الأصلي لاستاذنا الكبير خبور، تغير كثيرا الآن أرجو التوضيح رابط هذا التعليق شارك More sharing options...
saad abed قام بنشر نوفمبر 21, 2011 مشاركة قام بنشر نوفمبر 21, 2011 المهندس طارق هذا الموضوع جميل وشرح مفهوم بارك الله فيك وصبر فى توصيل المعلومة بارك الله فيك وارجو ان يكون لك بصمة فى دورة vba اشكركم تحياتى سعد عابد رابط هذا التعليق شارك More sharing options...
mhrrd قام بنشر نوفمبر 21, 2011 مشاركة قام بنشر نوفمبر 21, 2011 Sub Khboor_Tarheel() '============================================= ' الية الكود بعد الترحيل يقوم بمسح البيانات التي تم ترحيلها On Error Resume Next Application.ScreenUpdating = False For a = 11 To [a3000].End(xlUp).Row If Cells(a, 1) <> "" Then MySheets = Cells(a, 1) With Sheets(MySheets).[a3000].End(xlUp) .Offset(1, 0) = Cells(a, 1) .Offset(1, 1) = Cells(a, 2) .Offset(1, 2) = Cells(a, 3) .Offset(1, 3) = Cells(a, 4) .Offset(1, 4) = Cells(a, 5) .Offset(1, 5) = Cells(a, 6) .Offset(1, 6) = Cells(a, 7) .Offset(1, 7) = Cells(a, 8) .Offset(1, 8) = Cells(a, 9) .Offset(1, 9) = Cells(a, 10) .Offset(1, 10) = Cells(a, 11) .Offset(1, 11) = Cells(a, 12) .Offset(1, 12) = Cells(a, 13) .Offset(1, 13) = Cells(a, 14) .Offset(1, 14) = Cells(a, 15) .Offset(1, 15) = Cells(a, 16) .Offset(1, 16) = Cells(a, 17) .Offset(1, 17) = Cells(a, 18) .Offset(1, 18) = Cells(a, 19) .Offset(1, 19) = Cells(a, 20) .Offset(1, 20) = Cells(a, 21) .Offset(1, 21) = Cells(a, 22) .Offset(1, 22) = Cells(a, 23) .Offset(1, 23) = Cells(a, 24) .Offset(1, 24) = Cells(a, 25) .Offset(1, 25) = Cells(a, 26) .Offset(1, 26) = Cells(a, 27) .Offset(1, 27) = Cells(a, 28) .Offset(1, 28) = Cells(a, 29) .Offset(1, 29) = Cells(a, 30) .Offset(1, 30) = Cells(a, 31) .Offset(1, 31) = Cells(a, 32) .Offset(1, 32) = Cells(a, 33) .Offset(1, 33) = Cells(a, 34) .Offset(1, 34) = Cells(a, 35) .Offset(1, 35) = Cells(a, 36) .Offset(1, 36) = Cells(a, 37) .Offset(1, 37) = Cells(a, 38) .Offset(1, 38) = Cells(a, 39) .Offset(1, 39) = Cells(a, 40) End With End If ' If Sheets("ورقة1").Cells(a, "a") > "" Then Cells(a, 3).Resize(1, 4).Value = "" ' اذا اردت مسح البيانات بعد الترحيل حفز هذا السطر Next a Application.ScreenUpdating = True MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل" Range("a1").Select On Error Resume Next On Error GoTo 0 End Sub السلام عليكم لم أفهم ، ماذا تعني؟ الكود الأصلي لاستاذنا الكبير خبور، تغير كثيرا الآن أرجو التوضيح اقتباس جزاك الله كل خير وبارك لك هذا هو الكود والملف موجود بالمشاركه رقم15 لو نظرت في الملف تجد ان العمود A به المعيار مثل ناجح ودور تان وغير ذلك اريد ان اضع هذه المعايير في عمود آخر فأين الجزئيه التي اغير منها مع رجاء اضافه ميزة المسح رابط هذا التعليق شارك More sharing options...
يوسف عطا قام بنشر نوفمبر 21, 2011 الكاتب مشاركة قام بنشر نوفمبر 21, 2011 حفظ البيانات فى الشيت الأصلى لترحيلها لشيتات معينة على أساسها ثم إضافة ميزة المسح تكون بوضع الأسطر التالية قبل الكود On Error Resume Next Application.ScreenUpdating = False 'الجزء التالي يحفظ أسماء جميع الحالات الموجودة في العمود الأول rg1 = "A11:A" & [A3000].End(xlUp).Row Range(rg1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("X11"), Unique:=True Dim sht(9) As String, x(9) As Integer case_NO = [x100].End(xlUp).Row - 11 For i = 1 To case_NO sht(i) = Cells(11 + i, "X") Next i Range("X11:X" & 12 + case_NO).ClearContents 'الجزء التالي يمسح فقط المجال المطلوب من الشيتات التي أسماؤها مسجلة في الجزء السابق For sh = 1 To Sheets.Count For i = 1 To case_NO If Sheets(sh).Name = sht(i) Then Sheets(sh).Range("A11:U3000").ClearContents Next i Next sh عمود المعيار معرف هنا بأنه عمود رقم 1 لو تريد تغييره ضع بدلاً من الرقم 1 فى السطر الرابع من الكود الذى وضعته حضرتك فى المشاركة السابقة رقم العمود الذى به البيانات التى سيتم الرتحيل على اساسها وهو فى السطر الثانى من الجزء التالى من الكود For a = 11 To [A3000].End(xlUp).Row If Cells(a, 1) <> "" Then والله أعلم رابط هذا التعليق شارك More sharing options...
mhrrd قام بنشر نوفمبر 21, 2011 مشاركة قام بنشر نوفمبر 21, 2011 اشكرك كثيرا واريد ان ثضعه في ملف لو تكرمت رابط هذا التعليق شارك More sharing options...
يوسف عطا قام بنشر نوفمبر 21, 2011 الكاتب مشاركة قام بنشر نوفمبر 21, 2011 اشكرك كثيرا واريد ان ثضعه في ملف لو تكرمت أعطنى مثال عما تريد فى ملف ونا أحاول أطبق معاك الكود بناء على المطلوب رابط هذا التعليق شارك More sharing options...
mhrrd قام بنشر نوفمبر 21, 2011 مشاركة قام بنشر نوفمبر 21, 2011 اشكرك كثيرا واريد ان ثضعه في ملف لو تكرمت أعطنى مثال عما تريد فى ملف ونا أحاول أطبق معاك الكود بناء على المطلوب شكرا لردك وسأوافيك بالملف ان شاء الله رابط هذا التعليق شارك More sharing options...
طارق محمود قام بنشر نوفمبر 21, 2011 مشاركة قام بنشر نوفمبر 21, 2011 السلام عليكم أخي الحبيب mhrrd هذا البرنامج For a = 11 To [U3000].End(xlUp).Row If Cells(a, 21) <> "" Then MySheets = Cells(a, 21) Range(Cells(a, 1), Cells(a, 40)).Copy Sheets(MySheets).[A3000].End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues End If Next a يقوم بنفس عمل هذا For a = 11 To [a3000].End(xlUp).Row If Cells(a, 1) <> "" Then MySheets = Cells(a, 1) With Sheets(MySheets).[a3000].End(xlUp) .Offset(1, 0) = Cells(a, 1) .Offset(1, 1) = Cells(a, 2) .Offset(1, 2) = Cells(a, 3) .Offset(1, 3) = Cells(a, 4) .Offset(1, 4) = Cells(a, 5) .Offset(1, 5) = Cells(a, 6) .Offset(1, 6) = Cells(a, 7) .Offset(1, 7) = Cells(a, 8) .Offset(1, 8) = Cells(a, 9) .Offset(1, 9) = Cells(a, 10) .Offset(1, 10) = Cells(a, 11) .Offset(1, 11) = Cells(a, 12) .Offset(1, 12) = Cells(a, 13) .Offset(1, 13) = Cells(a, 14) .Offset(1, 14) = Cells(a, 15) .Offset(1, 15) = Cells(a, 16) .Offset(1, 16) = Cells(a, 17) .Offset(1, 17) = Cells(a, 18) .Offset(1, 18) = Cells(a, 19) .Offset(1, 19) = Cells(a, 20) .Offset(1, 20) = Cells(a, 21) .Offset(1, 21) = Cells(a, 22) .Offset(1, 22) = Cells(a, 23) .Offset(1, 23) = Cells(a, 24) .Offset(1, 24) = Cells(a, 25) .Offset(1, 25) = Cells(a, 26) .Offset(1, 26) = Cells(a, 27) .Offset(1, 27) = Cells(a, 28) .Offset(1, 28) = Cells(a, 29) .Offset(1, 29) = Cells(a, 30) .Offset(1, 30) = Cells(a, 31) .Offset(1, 31) = Cells(a, 32) .Offset(1, 32) = Cells(a, 33) .Offset(1, 33) = Cells(a, 34) .Offset(1, 34) = Cells(a, 35) .Offset(1, 35) = Cells(a, 36) .Offset(1, 36) = Cells(a, 37) .Offset(1, 37) = Cells(a, 38) .Offset(1, 38) = Cells(a, 39) .Offset(1, 39) = Cells(a, 40) End With End If ' If Sheets("ورقة1").Cells(a, "a") > "" Then Cells(a, 3).Resize(1, 4).Value = "" ' اذا اردت مسح البيانات بعد الترحيل حفز هذا السطر Next a بالإضافة لإختلاف عمود المعيار من A إلي U أرجو قراءة ودراسة المشاركة رقم 28 جيدا إن شاء الله تجد ماتريد رابط هذا التعليق شارك More sharing options...
mhrrd قام بنشر نوفمبر 22, 2011 مشاركة قام بنشر نوفمبر 22, 2011 كافأك الله بكل خير انا احاول جاهدا ان افهمها لانني بسيط جدا في الاكواد ويارب يسرها لي وللجميع وان لم استطع ساكتب لك ان شاء الله رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان