skyblue قام بنشر أكتوبر 24, 2011 مشاركة قام بنشر أكتوبر 24, 2011 السلام عليكم ورحمة الله وبركاته وبعد الاساتذة المشرفين والاعضاء الافاضل في الملف المرفق ارجوا التكرم بالمساعدة في التعديل على الكود بحيث انه في حالة الترحيل يتم مسح البيانات التي تم ترحيلها من ورقة 1 تحياتي للجميع المصنف2.rar رابط هذا التعليق شارك More sharing options...
عبدالله المجرب قام بنشر أكتوبر 24, 2011 مشاركة قام بنشر أكتوبر 24, 2011 اخي الفاضل ضع هذا السطر Range("D5:F14").Value = "" قبل هذا السطر في الكود On Error GoTo 0 ولاحظ النتيجة رابط هذا التعليق شارك More sharing options...
الـعيدروس قام بنشر أكتوبر 24, 2011 مشاركة قام بنشر أكتوبر 24, 2011 السلام عليكم او هكذا Sub Khboor_Tarheel() On Error Resume Next Application.ScreenUpdating = False For A = 5 To [C200].End(xlUp).Row If Cells(A, 3) <> "" Then MySheets = Cells(A, 3) With Sheets(MySheets).[B200].End(xlUp) .Offset(1, 0) = Cells(A, 4) .Offset(1, 1) = Cells(A, 5) .Offset(1, 2) = Cells(A, 6) .Offset(1, 3) = Cells(A, 7) End With End If Next A Application.ScreenUpdating = True MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل" Range("C5").Select last = WorksheetFunction.CountA(Range("d:f")) row_1 = "d5:f" & last Range(row_1).ClearContents On Error GoTo 0 End Sub رابط هذا التعليق شارك More sharing options...
عبدالله المجرب قام بنشر أكتوبر 24, 2011 مشاركة قام بنشر أكتوبر 24, 2011 السلام عليكم اضافة الى الطريقتين اعلاه يمكن استخدام هذا السطر ايضاً Range("D5:F14").Value = Empty والله اعلم رابط هذا التعليق شارك More sharing options...
skyblue قام بنشر أكتوبر 24, 2011 الكاتب مشاركة قام بنشر أكتوبر 24, 2011 استاذ عبدالله المجرب ابو احمد والاستاذ العيدروس اشكركم على المساعدة والحلول كلها رائعة . لكن ماكنت اقصده الاتي : انا اقصد لو انني رحلت الصف من d5: f5 الى ورقة احمد فان البيانات من d5:f5 تنمسح بمجرد الترحيل وهكذا للصف التالي . والتعديل اللي اتفضلتم بعمله يودي الى مسح الكل . لانني احيانا اريد ان ارحل صف واحد فقط لورقة باسم والباقي لااريد تلرحيله هذا مااردت توضيحه والله يحفظكم رابط هذا التعليق شارك More sharing options...
الـعيدروس قام بنشر أكتوبر 24, 2011 مشاركة قام بنشر أكتوبر 24, 2011 الكود لايوجد به ترحيل مخصص اذا كنت تقصد انك تريد تحديد الصف المراد ترحيله ومن ثم مسح بيانات الصف بعد الترحيل بمعنى اضافة على الكود هذا شي اخر ارجو التوضيح رابط هذا التعليق شارك More sharing options...
الـعيدروس قام بنشر أكتوبر 24, 2011 مشاركة قام بنشر أكتوبر 24, 2011 اخي الفاضل تم عمل المطلوب بالمقدور عليه اضطررت لعمل معادلة في عمود A وهذا هو الكود Sub Khboor_Tarheel() On Error Resume Next Application.ScreenUpdating = False For A = 5 To [C200].End(xlUp).Row If Cells(A, 3) <> "" Then MySheets = Cells(A, 3) With Sheets(MySheets).[B200].End(xlUp) .Offset(1, 0) = Cells(A, 4) .Offset(1, 1) = Cells(A, 5) .Offset(1, 2) = Cells(A, 6) .Offset(1, 3) = Cells(A, 7) End With End If Next A Application.ScreenUpdating = True MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل" Range("C5").Select Sheets("ورقة1").Activate Application.ScreenUpdating = False Application.EnableEvents = False On Error Resume Next Dim rngData As Range Dim rngRow As Range Set rngData = ورقة1.Range("a5:a1000") For Each rngRow In rngData.Rows If Application.WorksheetFunction.CountIf(Sheets("ورقة1").Range("a5:a1000"), Cells(rngRow, 1)) < 0 Then rngRow.Select Else rngRow.Offset(0, 3).Resize(1, 3).ClearContents End If Next rngRow Application.ScreenUpdating = True Application.EnableEvents = True On Error GoTo 0 End Sub وهذا المرفق مصنف_alidroos.rar رابط هذا التعليق شارك More sharing options...
عبدالله المجرب قام بنشر أكتوبر 24, 2011 مشاركة قام بنشر أكتوبر 24, 2011 (معدل) الاستاذ الفاضل ابو نصار عمل مميز ونشاط ملحوظ ================ اثراءً للموضوع هذا الكود بعد التعديل Sub Khboor_Tarheel() On Error Resume Next Application.ScreenUpdating = False For A = 5 To [C200].End(xlUp).Row Dim cl As Range Set myrng = Range("C5:C" & [C200].End(xlUp).Row) If Cells(A, 3) <> "" Then MySheets = Cells(A, 3) With Sheets(MySheets).[B200].End(xlUp) .Offset(1, 0) = Cells(A, 4) .Offset(1, 1) = Cells(A, 5) .Offset(1, 2) = Cells(A, 6) .Offset(1, 3) = Cells(A, 7) End With End If Next A Application.ScreenUpdating = True MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل" Range("C5").Select For Each cl In myrng If cl.Value <> "" Then Range(Cells(cl.Row, 4), Cells(cl.Row, 7)).Value = "" End If Next cl On Error GoTo 0 End Sub تم تعديل أكتوبر 24, 2011 بواسطه اا عبدالله المجرب اا رابط هذا التعليق شارك More sharing options...
الـعيدروس قام بنشر أكتوبر 24, 2011 مشاركة قام بنشر أكتوبر 24, 2011 السلام عليكم ماشاء الله كود مختصر وجميل بارك الله فيك كل يوم نستفيد منك (يادينمو المنتدى) ومع البهارات(دينمو اتوماتيك) تحياتي رابط هذا التعليق شارك More sharing options...
الـعيدروس قام بنشر أكتوبر 24, 2011 مشاركة قام بنشر أكتوبر 24, 2011 وهذا حل اخر ملخص Sub Khboor_Tarheel() On Error Resume Next Application.ScreenUpdating = False For A = 5 To [C200].End(xlUp).Row If Cells(A, 3) <> "" Then MySheets = Cells(A, 3) With Sheets(MySheets).[B200].End(xlUp) .Offset(1, 0) = Cells(A, 4) .Offset(1, 1) = Cells(A, 5) .Offset(1, 2) = Cells(A, 6) .Offset(1, 3) = Cells(A, 7) End With End If Next A Application.ScreenUpdating = True MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل" Range("C5").Select On Error Resume Next On Error GoTo 0 '============================================================================= For i = 5 To 1000 If Sheets("ورقة1").Cells(i, "c") > "" Then Cells(i, 3).Resize(1, 4).Value = "" Next i End Sub رابط هذا التعليق شارك More sharing options...
عبدالله المجرب قام بنشر أكتوبر 24, 2011 مشاركة قام بنشر أكتوبر 24, 2011 السلام عليكم اخي ابو نصار سلمت يدك الا اختصرت الكود بارك الله فيك وفتح لك من العلم اوسعه ابواحمد رابط هذا التعليق شارك More sharing options...
الـعيدروس قام بنشر أكتوبر 24, 2011 مشاركة قام بنشر أكتوبر 24, 2011 استاذي القدير عبدالله المجرب لك مثل دعائك اضعاف مضاعفه قل امين تسلم على هذا التشجيع رابط هذا التعليق شارك More sharing options...
الـعيدروس قام بنشر أكتوبر 24, 2011 مشاركة قام بنشر أكتوبر 24, 2011 او بنفس حلقة تكرار الترحيل هكذا Sub Khboor_Tarheel() On Error Resume Next Application.ScreenUpdating = False For a = 5 To [C200].End(xlUp).Row If Cells(a, 3) <> "" Then MySheets = Cells(a, 3) With Sheets(MySheets).[B200].End(xlUp) .Offset(1, 0) = Cells(a, 4) .Offset(1, 1) = Cells(a, 5) .Offset(1, 2) = Cells(a, 6) .Offset(1, 3) = Cells(a, 7) End With End If If Cells(a, 3) > "" Then Cells(a, 4).Resize(1, 4).Value = "" Next a Application.ScreenUpdating = True MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل" Range("C5").Select On Error GoTo 0 End Sub الفرغه تعمل عمايل رابط هذا التعليق شارك More sharing options...
skyblue قام بنشر أكتوبر 24, 2011 الكاتب مشاركة قام بنشر أكتوبر 24, 2011 اشكركم على التفاعل الرائع وهذا ات دل يدل على طيبنكم وحب المساعدة للاخرين وهذا مالمستاه مت كل اخواتتا في هذا المتندى . شكرا على الحلول الني ندل على خبرة نراكمية لدى كل متكم . فعلا هذا هو المطلوب ولكن احترت اخذ اية كود كلها اكواد حلوة ورائعة وتؤدي الغرض بامنياز . اسناذ عبدالله المحارب لك مني :fff: وهذه ايضا للاسناذ العيدروس :fff: اادعوا الله لكم بالتوفيق رابط هذا التعليق شارك More sharing options...
saad abed قام بنشر أكتوبر 24, 2011 مشاركة قام بنشر أكتوبر 24, 2011 اخى عبدالله المجرب و اخى ابو نصار فتح الله عليكم ابوب العلم والمعرفة بسم الله ما شاء الله لا قوة الا بالله جزاكم الله خيرا سعد عابد رابط هذا التعليق شارك More sharing options...
الـعيدروس قام بنشر أكتوبر 25, 2011 مشاركة قام بنشر أكتوبر 25, 2011 الاستاذ الحبيب سعد عابد جزاك الله خير على كلماتك الطيبه موفق ياخلوق رابط هذا التعليق شارك 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.