ترحيل بيانات محددة بمدى معين

[skyblue]

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

الاخوة الامشرفين والاعضاء المحترمين برجاء التكرم بالتعديل على الملف المرفق . علما ان الكود يخص الاستاذ / عمادالحسامي

ولكن اناعدلت عليه في هذا الملف المرفق .

تحياتي

Book1.rar

[طارق محمود]

السلام عليكم

أخي العزيز

أولا إوقف تفعيل مسح البيانات القديمة

السطر الثالث من الكود

sheet2.Range("e6:h64").ClearContents

ثانيا ضع متغيرات أخري تعد البيانات الموجودة في كل منطقة لتغير بداية وضع البيانات s , s1 , s2 , s3

سيكون الكود كالتالي بعد التعديل

Sub ss()

Application.ScreenUpdating = False

'sheet2.Range("e6:h64").ClearContents

s = 6: s1 = 21: s2 = 37: s3 = 53


a = WorksheetFunction.CountA(sheet2.Range("e6:e20"))

a1 = WorksheetFunction.CountA(sheet2.Range("e21:e36"))

a2 = WorksheetFunction.CountA(sheet2.Range("e37:e52"))

a3 = WorksheetFunction.CountA(sheet2.Range("e53:e64"))


s = s + a

s1 = s1 + a1

s2 = s2 + a2

s3 = s3 + a3


	For i = 6 To 10

    	If sheet1.Cells(i, "d") <> 0 Then

        	sheet2.Cells(s, "e") = sheet1.Cells(i, "c")

        	sheet2.Cells(s, "g") = sheet1.Cells(i, "d")

        	s = s + 1

    	End If

    	If sheet1.Cells(i, "e") <> 0 Then

        	sheet2.Cells(s1, "e") = sheet1.Cells(i, "c")

        	sheet2.Cells(s1, "h") = sheet1.Cells(i, "e")

        	s1 = s1 + 1

    	End If

    	If sheet1.Cells(i, "f") <> 0 Then

        	sheet2.Cells(s2, "e") = sheet1.Cells(i, "c")

        	sheet2.Cells(s2, "g") = sheet1.Cells(i, "f")

        	s2 = s2 + 1

    	End If

    	If sheet1.Cells(i, "g") <> 0 Then

        	sheet2.Cells(s3, "e") = sheet1.Cells(i, "c")

        	sheet2.Cells(s3, "h") = sheet1.Cells(i, "g")

        	s3 = s3 + 1

    	End If

	Next

sheet2.Select

Application.ScreenUpdating = True

End Sub

[طارق محمود]

مرفق الملف وبه الكود المعدل

Book1-2.rar

[skyblue]

شكرا الة المرافب العام TAREQ3 فعلا هذا هو الكود المطوب وجزاك الله خيرا على هذا الكود الرائع .

ولكن لي ملاحظة او تكة بسيطة جدا عند استخدام الكود فمثلا عند ترحيل بيانات A الى الورق2 من المفترض ان يتوقف الكودعندE20

مثل ماهو محدد له سابقا ,,, لكنه يتعدى في الترحيل الى الخانةE21 الخاصة ب B

اتمنى التكرم والتفضل بالتعديل على الكود بحيث انه في حالة ترحيل بيانات A فان الكود يرحل الى الورقة2 حتى المدى E20

ونفس الوضع ل b , c , d

تقبل تحياتي

[طارق محمود]

السلام عليكم

يمكنك إضافة سطرين للكود بعد سطر أمر For مباشرة

وهما

ddd = "المدي المتاح لنقل البيانات غير فارغ " & Chr(10) & "أفرغ المدي أولا ثم إنقل البانات"

If s > 20 Or s1 > 36 Or s2 > 52 Or s3 > 64 Then MsgBox (ddd): Exit Sub

ليكون الكود كالتالي

...

  For i = 6 To 10

    	ddd = "المدي المتاح لنقل البيانات غير فارغ " & Chr(10) & "أفرغ المدي أولا ثم إنقل البانات"

    	If s > 20 Or s1 > 36 Or s2 > 52 Or s3 > 64 Then MsgBox (ddd): Exit Sub

        	If sheet1.Cells(i, "d") <> 0 Then

            	sheet2.Cells(s, "e") = sheet1.Cells(i, "c")

            	sheet2.Cells(s, "g") = sheet1.Cells(i, "d")

            	s = s + 1

        	End If

...

[skyblue]

مشكوووور استاذي tareQ m الله يوفقك للخير وأسأل الله ان يكون التوفيق حليفك في كل شي