طارق محمود قام بنشر نوفمبر 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 إن وجدت صعوبة إرسل لي مثالا به البيانات بالشكل المطلوب
يوسف عطا قام بنشر نوفمبر 20, 2011 الكاتب قام بنشر نوفمبر 20, 2011 شاكر أفضالك مرة أخرى فعلاً حاولت ولم أحقق نتيجة مرضية ولا أعرف ما علاقة عمود GX بالموضوع على العموم مرفق الملف كما أتصوره وتم تبديل العمود U ليكون بديلاً للعمود A ومن تعديلك للكود سأحاول أن أكتشف ما أريد عند المقارنة بين التعديلين تعديل ترحيل.rar
طارق محمود قام بنشر نوفمبر 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
الـعيدروس قام بنشر نوفمبر 20, 2011 قام بنشر نوفمبر 20, 2011 السلام عليكم الاستاذ القدير طارق محمود كود جميل وشرح ولااروع جزاك الله خير وجعله في ميزان حسناتك
يوسف عطا قام بنشر نوفمبر 20, 2011 الكاتب قام بنشر نوفمبر 20, 2011 ربنا يزيدك من العلم يا استاذ طارق ويجازيك خيراً ويجعل أعمالك فى موازين حسناتك
mhrrd قام بنشر نوفمبر 21, 2011 قام بنشر نوفمبر 21, 2011 اكثر الله من خيرك استاذ طارق ** لو سمحت طبق هذه التغييرات على الكود الاصلي الخاص بالاستاذ خبور لانني ارى امامي فيه الاعمده التي اود ان اضيفها او ازيلها بعد اذنك جزاك الله خيرا
طارق محمود قام بنشر نوفمبر 21, 2011 قام بنشر نوفمبر 21, 2011 السلام عليكم لم أفهم ، ماذا تعني؟ الكود الأصلي لاستاذنا الكبير خبور، تغير كثيرا الآن أرجو التوضيح
saad abed قام بنشر نوفمبر 21, 2011 قام بنشر نوفمبر 21, 2011 المهندس طارق هذا الموضوع جميل وشرح مفهوم بارك الله فيك وصبر فى توصيل المعلومة بارك الله فيك وارجو ان يكون لك بصمة فى دورة vba اشكركم تحياتى سعد عابد
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 به المعيار مثل ناجح ودور تان وغير ذلك اريد ان اضع هذه المعايير في عمود آخر فأين الجزئيه التي اغير منها مع رجاء اضافه ميزة المسح
يوسف عطا قام بنشر نوفمبر 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 والله أعلم
يوسف عطا قام بنشر نوفمبر 21, 2011 الكاتب قام بنشر نوفمبر 21, 2011 اشكرك كثيرا واريد ان ثضعه في ملف لو تكرمت أعطنى مثال عما تريد فى ملف ونا أحاول أطبق معاك الكود بناء على المطلوب
mhrrd قام بنشر نوفمبر 21, 2011 قام بنشر نوفمبر 21, 2011 اشكرك كثيرا واريد ان ثضعه في ملف لو تكرمت أعطنى مثال عما تريد فى ملف ونا أحاول أطبق معاك الكود بناء على المطلوب شكرا لردك وسأوافيك بالملف ان شاء الله
طارق محمود قام بنشر نوفمبر 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 جيدا إن شاء الله تجد ماتريد
mhrrd قام بنشر نوفمبر 22, 2011 قام بنشر نوفمبر 22, 2011 كافأك الله بكل خير انا احاول جاهدا ان افهمها لانني بسيط جدا في الاكواد ويارب يسرها لي وللجميع وان لم استطع ساكتب لك ان شاء الله
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.