كود ترحيل صفوف من صفحات الي صفحه بناء علي شرط

[أيهاب ممدوح]

مطلوب ترحيل كل المستأجرين المتأخرين في كل الصفحات الي صفحه واحده ويكتب جنب كل مستأجر اسم الصفحه التي تم ترحيله منها

حتي يتم معرفه اسم المستأجر واسم العمارة وشكرا

الايجارات (2).xlsm

[ابراهيم الحداد]

السلام عليكم ورخمة الله

استخدم هذا الكود

Sub RentLate()
Dim C As Range
Dim ws As Worksheet, Sh As Worksheet
Dim p As Long
p = 5
Set ws = Sheets("المتأخرين")
For Each Sh In Worksheets
If Sh.Name <> "المتأخرين" Then
For Each C In Sh.Range("D6:D" & Sh.Range("D" & Rows.Count).End(xlUp).Row)
If C.Value = 0 Then
p = p + 1
ws.Cells(p, 1) = p - 5
ws.Cells(p, 2) = C.Offset(0, 12)
ws.Cells(p, 3) = C.Worksheet.Name
End If
Next
End If
Next
End Sub

 

[أيهاب ممدوح]

اخي الكريم

شكرا علي مجهودك

لكن الكود يقوم بترحيل الغير متأخرين  ( المتأخرين يتم تحديدهم عن طريق العمود d الذي به عدد ايام التأخير )

ويقوم بجلب كل الصف وليس الاسم فقط 

 

[أيهاب ممدوح]

اخي الكريم

مطلوب ترحيل كامل الصف للمستأجر مع اسم الصفحه او خلايا معينه مثل رقم الشقه تاريخ الانتهاء وعدد ايام التأخير والايجار ورقم الجوال

Sub RentLate()
Dim c As Range
Dim ws As Worksheet, Sh As Worksheet
Dim p As Long
p = 5
Set ws = Sheets("المتأخرين")
For Each Sh In Worksheets
If Sh.Name <> "المتأخرين" Then
For Each c In Sh.Range("D6:D" & Sh.Range("D" & Rows.Count).End(xlUp).Row)
If c.Value > 0 And c.Value < 1000 Then
p = p + 1
ws.Cells(p, 1) = p - 5
ws.Cells(p, 2) = c.Offset(0, 12)
ws.Cells(p, 3) = c.Worksheet.Name
End If
Next
End If
Next
End Sub

 

[أيهاب ممدوح]

Sub RentLate()
Dim c As Range
Dim ws As Worksheet, Sh As Worksheet
Dim p As Long
p = 5
Set ws = Sheets("المتأخرين")
For Each Sh In Worksheets
If Sh.Name <> "المتأخرين" Then
For Each c In Sh.Range("D6:D" & Sh.Range("D" & Rows.Count).End(xlUp).Row)
If c.Value > 0 And c.Value < 1000 Then
p = p + 1
ws.Cells(p, 1) = p - 5
ws.Cells(p, 3) = c.Offset(0, 12)
ws.Cells(p, 4) = c.Offset(0, 11)
ws.Cells(p, 5) = c.Offset(0, 10)
ws.Cells(p, 6) = c.Offset(0, 9)
ws.Cells(p, 7) = c.Offset(0, 8)
'ws.Cells(p, 8) = c.Offset(0, 7)
'ws.Cells(p, 9) = c.Offset(0, 6)
ws.Cells(p, 10) = c.Offset(0, 5)
ws.Cells(p, 11) = c.Offset(0, 3)
ws.Cells(p, 12) = c.Offset(0, 0)
ws.Cells(p, 13) = c.Offset(0, -1)
ws.Cells(p, 2) = c.Worksheet.Name
End If
Next
End If
Next
End Sub

شكرا اخي الكريم

الكود كده يفي بالغرض ولكن لو امكن اضافه حذف النطاق قبل تنفيذ الكود لكي تكون البيانات محدثه

[نبيل عبد الهادي]

جرب الملف المرفق تم عمل 

1- ترحيل المتاخرين في ورقة المتاخرين لكل عمارة بنطاق خاص بها اعتمادا على العمود D

2- حذف النطاقات قبل تنفيذ الكود لكي تكون البيانات محدثه (وللتجربة حدث البيانات ثم رحل )

 

الايجارات - ايهاب .xlsm

تم تعديل مارس 12, 2018 بواسطه نبيل عبد الهادي

[أيهاب ممدوح]

اخي الكريم نبيل

كود ممتاز ويعمل المطلوب 

ولكن فيه بعض العقبات طول الكود وصعوبه تعقبه

وامكانيه اضافه الصفحات الاخري

وشكرا