مسح البيانات بعد ترحيلها

**skyblue** · أكتوبر 24, 2011

السلام عليكم ورحمة الله وبركاته وبعد

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

تحياتي للجميع

المصنف2.rar

**عبدالله المجرب** · أكتوبر 24, 2011

اخي الفاضل

ضع هذا السطر


Range("D5:F14").Value = ""

قبل هذا السطر في الكود


On Error GoTo 0

ولاحظ النتيجة

**الـعيدروس** · أكتوبر 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

**عبدالله المجرب** · أكتوبر 24, 2011

السلام عليكم

اضافة الى الطريقتين اعلاه

يمكن استخدام هذا السطر ايضاً


Range("D5:F14").Value = Empty

والله اعلم

**skyblue** · أكتوبر 24, 2011

استاذ عبدالله المجرب ابو احمد والاستاذ العيدروس اشكركم على المساعدة والحلول كلها رائعة . لكن ماكنت اقصده الاتي :

انا اقصد لو انني رحلت الصف من d5: f5 الى ورقة احمد

فان البيانات من d5:f5 تنمسح بمجرد الترحيل وهكذا للصف التالي .

والتعديل اللي اتفضلتم بعمله يودي الى مسح الكل . لانني احيانا اريد ان ارحل صف واحد فقط لورقة باسم والباقي لااريد تلرحيله

هذا مااردت توضيحه

والله يحفظكم

**الـعيدروس** · أكتوبر 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

**عبدالله المجرب** · أكتوبر 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 بواسطه اا عبدالله المجرب اا

**الـعيدروس** · أكتوبر 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

**عبدالله المجرب** · أكتوبر 24, 2011

السلام عليكم

اخي ابو نصار

سلمت يدك

الا اختصرت الكود

بارك الله فيك وفتح لك من العلم اوسعه

ابواحمد

**الـعيدروس** · أكتوبر 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

الفرغه تعمل عمايل

**skyblue** · أكتوبر 24, 2011

اشكركم على التفاعل الرائع وهذا ات دل يدل على طيبنكم وحب المساعدة للاخرين وهذا مالمستاه مت كل اخواتتا في هذا المتندى . شكرا على الحلول الني ندل على خبرة نراكمية لدى كل متكم .

فعلا هذا هو المطلوب ولكن احترت اخذ اية كود كلها اكواد حلوة ورائعة وتؤدي الغرض بامنياز .

اسناذ عبدالله المحارب لك مني :fff: :fff: :fff: وهذه ايضا للاسناذ العيدروس :fff: :fff: :fff:

اادعوا الله لكم بالتوفيق

**saad abed** · أكتوبر 24, 2011

اخى عبدالله المجرب و اخى ابو نصار

فتح الله عليكم ابوب العلم والمعرفة

بسم الله ما شاء الله لا قوة الا بالله

جزاكم الله خيرا

سعد عابد

**الـعيدروس** · أكتوبر 25, 2011

الاستاذ الحبيب سعد عابد جزاك الله خير

على كلماتك الطيبه

موفق ياخلوق

تسجيل الدخول

مسح البيانات بعد ترحيلها

الردود الموصى بها

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

من فضلك سجل دخول لتتمكن من التعليق

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information