ترحيل بيانات مدى محدد إلى صفحة أخرى بشرط

[أبو أنس حاجب]

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

أساتذتي الكرام حفظكم الله

المطلوب كود يقوم بنقل البيانات من المدى A:S التي رصيدها صفر في العمود U إلي الصفحة المجاورة ومسح بياناتها من المصدر مع فرز بيانات المصدر للتخلص من الفراغات (وذلك حسب عمود Duty Date) وهكذا ستكون العملية في حالة تم تعديل بيانات أخرى وتم تصفير رصيدها (أي ان عملية البيانات في هذه الصفحة ستكون متغيرة حسب الحاجة مع الاحتفاظ بما تم ترحيله إلى الصفحة الاخرى وفق ترتيب الترحيل).

والله الموفق

أبو أنس

نقل بيانات المدفوعات المسدده.rar

هذا كود تسجيلي قمت باضافته لاحقاً وهو يحقق المطلوب هل هنالك ماهو أفضل منه:

Sub ExportClearedPayment()

ActiveSheet.Unprotect

Sheets("Cleared Payment").Select

ActiveSheet.Unprotect

[A65536].End(xlUp).Offset(1, 0).Select

Sheets("Payment").Select

Selection.AutoFilter Field:=21, Criteria1:="0.00"

Range("A5:S2000").Select

Selection.Copy

Sheets("Cleared Payment").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

Sheets("Payment").Select

Application.CutCopyMode = False

Selection.ClearContents

Selection.AutoFilter Field:=21

Selection.Sort Key1:=Range("F5"), Order1:=xlAscending, Header:=xlGuess, _

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

DataOption1:=xlSortNormal

Sheets("Payment").Protect , Sheets("Cleared Payment").Protect

End Sub

تم تعديل نوفمبر 5, 2012 بواسطه أبو أنس حاجب

[أبو حنــــين]

إستعمل هذا الكود ربما يفي بالغرض

Sub Hanine()

Dim LR As Integer, x As Integer

LR = [A10000].End(xlUp).Row

Sheets("Cleared Payment").Range("A5:R1000").ClearContents

Application.ScreenUpdating = False

x = 5

    For s = 5 To LR

	    If Cells(s, 21).Value = 0 Then

		    Range("a" & s).Resize(1, 18).Copy

			    Sheets("Cleared Payment").Range("A" & x).PasteSpecial xlPasteValues

		    Application.CutCopyMode = False

	    x = x + 1

    End If

Next s

MsgBox "Êã ÇáÊÑÍíá ÇáÈíÇäÇÊ ÈäÌÇÍ", vbInformation + vbMsgBoxRight, "ÊÑÌíá"

Application.ScreenUpdating = True

End Sub

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل أبا حنين حفظكم الله وأهلكم جميعاً.

جزاك الله كل خير على هذا الكود الجميل.

أرجو أن تسمح لي ببعض الملاحظات:

1. الكود يقوم بنقل البيانات الصفرية لمرة واحدة فقط بشكل كلي (ما أريده هو النقل حسب المتغير في الصفحة المصدر- أي في حالة غيرت عمليتين واصبح رصيدهم صفري مثلاُ أضغط على الزر فيقوم بنقل بياناتهما إلى الصفحة الهدف وهكذا بعد ذلك إذا غيرت عدة عمليات مجتمعة أو فرادا (بضغظة زر أخرى) يتم نقلها اسفل أخر نقل حتى يصبح لدي تقرير بالعمليات المنجزة).

2. المطلوب بعد كل عملية (أي بعد كل ضغطة زر) أن يتم مسح البيانات المرحلة من المصدرثم إعادة فرز البيانات للتخلص من الفراغات على أن يشمل الفرز فقط المدى A:S

ملاحظة طفيفة المدى A:S وليس A:R مع مراعاة الحماية في الملف.

والله الموفق وخير معين

أبو أنس

[احمدزمان]

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

بعد الشكر و التقدير لأخي الفاضل ابو حنين على الكود الجميل

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

اخي انس حل آخر

Dim FS As Worksheet, TS As Worksheet, RN1 As Range, ER, TR, T, R

Set FS = Sheets("Payment")

Set TS = Sheets("Cleared Payment")

'For R = 8 To Application.CountA(Range("au8:au5000"))

ER = Application.CountA(FS.Range("C1:C55555")) + 9

TR = Application.CountA(TS.Range("A1:A55555")) + 5

For R = 5 To ER

If FS.Range("U" & R) = 0 Then

Set RN1 = FS.Range("A" & R & ":S" & R)

RN1.Copy

TS.Range("A" & TR).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

	 :=False, Transpose:=False

RN1.ClearContents

TR = TR + 1

End If

Next R

Application.CutCopyMode = False

Set RN1 = FS.Range("A5:U" & ER)

RN1.Sort Key1:=Range("C5")

[احمدزمان]

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

بعد الشكر و التقدير لأخي الفاضل ابو حنين على الكود الجميل

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

اخي انس حل آخر

Dim FS As Worksheet, TS As Worksheet, RN1 As Range, ER, TR, T, R

Set FS = Sheets("Payment")

Set TS = Sheets("Cleared Payment")

'For R = 8 To Application.CountA(Range("au8:au5000"))

ER = Application.CountA(FS.Range("C1:C55555")) + 9

TR = Application.CountA(TS.Range("A1:A55555")) + 5

For R = 5 To ER

If FS.Range("U" & R) = 0 Then

Set RN1 = FS.Range("A" & R & ":S" & R)

RN1.Copy

TS.Range("A" & TR).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

	 :=False, Transpose:=False

RN1.ClearContents

TR = TR + 1

End If

Next R

Application.CutCopyMode = False

Set RN1 = FS.Range("A5:U" & ER)

RN1.Sort Key1:=Range("C5")

نقل بيانات المدفوعات المسدده.rar

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل أحمد زمان حفظكم الله

جزاك الله كل خير وبارك الله بك وفيك على الرد.

اصبحنا قريبين جداً من المطلوب كاملاً.

1. النقل للبيانات يبدأ في الصفحة الثانية حسب الكود من السطرالسادس وما اريده ان يبدا من السطر الخامس وقد غيرت الرقم 5 إلى الرقم 4 في هذا السطر أدناه وضبط ارجو التوجية بصحة ذلك

TR = Application.CountA(TS.Range("A1:A55555")) + 5

2. في حالة كانت البيانات التي ارصدتها صفرية لاكثر من سطر (اي ان الكود يعمل فقط اذا كان النقل لسطر واحد) يقف الكود عن آخر سطر وأظنه الخاص بالفرز ولا يقوم بتنفذ الفرز.

اكتفي حالياً بهاتين الملاحظتين والمراجعة ستكون تباعاً للملف اذا تفضلت وسمح وقتك بذلك (أرجو ملاحظة ان الكود التسجيلي الذي ارفقته يقوم بالمطلوب بدقة ولا يتأثر بالضغط على الزر مرات متعددة واذا كانت هنالك بيانات تحتاج او لا تحتاج للتحديث ولكني حبيت تبديله بكود احترافي).

أدام الله علينا حضورك بيننا في المنتدى

أبو أنس

[الـعيدروس]

السلام عليكم

جرب هذا الكود

Public Sub ali_Su()

Dim Rt As Range

Dim Sr As Worksheet

Set Sr = ورقة2

ActiveSheet.Unprotect

Sr.Unprotect

With Application

  .EnableEvents = False

  .ScreenUpdating = False

With ActiveSheet

.Rows("5:65536").Sort Key1:=.Cells(5, 21), Order1:=xlDescending, Header:=xlNo

.Cells(5, 21).HorizontalAlignment = xlRight

E = Sr.Cells(Rows.Count, 1).End(xlUp).Row + 1

For Each Rt In .Range("A5:A" & .Cells(Rows.Count, 1).End(xlUp).Row)

If Rt.Value > "" And .Cells(Rt.Row, 21) = 0 Then

  Range(Cells(Rt.Row, 1), Cells(Rt.Row, 21)).Copy

  Sr.Cells(E, 1).PasteSpecial xlPasteValues

  E = E + 1

  R = R & "," & Cells(Rt.Row, 1).Address

  Application.CutCopyMode = False

End If

Next

Ae = Mid(R, 2, Len(R))

Range(Ae).EntireRow.Delete Shift:=xlUp

.Rows("5:65536").Sort Key1:=.Cells(5, 21), Order1:=xlDescending, Header:=xlNo

.Cells(5, 21).HorizontalAlignment = xlRight

End With

  .EnableEvents = True

  .ScreenUpdating = True

End With

Sr.Protect

ActiveSheet.Protect

End Sub

تم تعديل نوفمبر 8, 2012 بواسطه عباد

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل أبا نصار حفظكم الله

بارك الله فيكم وبكم ورفع قدركم جاري التجربة وسوف أخبركم بالنتيجة.

أستاذي وسيدي الفاضل أحمد زمان حفظكم الله

تم موافقة ملفي مع ما يقتضيه كودكم الجميل وحلت جميع الاشكاليات.

تقبل خالص الشكر والتقدير والعرفان يا نبيل الخلق أعزك الله دنيا وآخرة.

أبو أنس