ترحيل بشرط

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

السلام عليكم

ارجوا من الاخوة الاعزاء

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

برنامج ايجار.xlsm

[احمدزمان]

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

جرب المرفق

Sub MUTAKHEEN_ALL()
Dim FS As Worksheet, TS As Worksheet
Dim ER, FSN, FR, TR
Set TS = Sheets("ÊÃÎíÑ")
TR = 6
For FSN = 1 To Sheets.Count
Set FS = Sheets(FSN)
If FS.Name = TS.Name Then GoTo 9
With FS
For FR = 5 To 999
If .Cells(FR, 14) < 0 Then
For FC = 1 To 18
TS.Cells(TR, FC) = .Cells(FR, FC)
Next FC
TS.Cells(TR, 19) = .Name
TR = TR + 1
End If
Next FR
End With
9 Next FSN
End Sub

 

برنامج ايجار.xlsm

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

السلام عليكم 

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

ولكن هل بالامكان ان يكون كل شيت في قائمه لحاله

هل ممكن جعل الترحيل يقوم بفصل كل بيانات خاصه بشيت لوحدة 

وليس قائمه متصله

[الـعيدروس]

السلام عليكم

بعد اذن استاذنا الحبيب احمد زمان

هذا تعديل بسيط على الكود

Sub MUTAKHEEN_ALL()
Dim FS As Worksheet, TS As Worksheet
Dim ER, FSN, FR, TR, A, Rw
Set App = WorksheetFunction
Set TS = Sheets("تأخير")
TS.Range("A6:S500").Clear
TR = 6
For FSN = 1 To Sheets.Count
Set FS = Sheets(FSN)
If FS.Name = TS.Name Then GoTo 9
With FS
On Local Error Resume Next
A = App.Match(.Name, TS.Range("J:J"), 0)
If Err <> 0 Then
If App.CountIf(.Range("N:N"), "<0") = 0 Then GoTo 9
  Rw = TS.Cells(TS.Rows.Count, "J").End(xlUp).Row + 1
  TS.Rows(2).Copy TS.Range("A" & Rw)
  TS.Range("A3:Q5").Copy
  TS.Range("A" & Rw + 1).PasteSpecial xlPasteFormats
  TS.Range("A" & Rw + 1).PasteSpecial xlPasteValues
  TS.Range("J" & Rw + 1).Value = .Name
  Err.Clear
End If
TR = App.Match(.Name, TS.Range("J:J"), 0) + 3
For FR = 5 To 999
If .Cells(FR, 14) < 0 Then
For FC = 1 To 17
If Not IsNull(TS.Cells(TR, FC).Borders.Value) Then TS.Cells(TR, FC).Borders.Weight = xlThin
TS.Cells(TR, FC) = .Cells(FR, FC)
Next FC
TS.Cells(TR, 19) = .Name
TR = TR + 1
End If
Next FR
End With
9 Next FSN
Set TS = Nothing: Set FS = Nothing: Set App = Nothing
End Sub

 

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

شكرا استاذنا العزيز

جاري التجربه

استاذ العيدروس

جزاك الله خير

الكود هو المطلوب تمام

ولكن بقي جزئ بسيط

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

[احمدزمان]

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

نحن نتعلم منكم

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

 

اخي الكريم

من وجهة نظري

الافضل استخدام التصفية التلقائية

حيث تم وضع اسم الصفحة جوار الجدول

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

*************************

و لقد قام اخي الفاضل العيدروس بتنفيذ طلبك

 

وهكذا كل الحلول لديك

 

[الـعيدروس]

كما اشار استاذنا الحبيب احمد زمان

بإمكانك استخدام التصفية 

او في حالة ملفك بشكلة الحالي وعدد الاسطر

بالامكان استخدام هذا التعديل

Sub MUTAKHEEN_ALL()
Dim FS As Worksheet, TS As Worksheet
Dim ER, FSN, FR, TR, A, Rw
Dim Rn As Range
Dim Rng As Range
Set App = WorksheetFunction
Set TS = Sheets("تأخير")
TS.Range("A6:S500").Clear
TR = 6
For FSN = 1 To Sheets.Count
Set FS = Sheets(FSN)
If FS.Name = TS.Name Then GoTo 9
With FS
On Local Error Resume Next
A = App.Match(.Name, TS.Range("J:J"), 0)
If Err <> 0 Then
If App.CountIf(.Range("N:N"), "<0") = 0 Then GoTo 9
  Rw = TS.Cells(TS.Rows.Count, "J").End(xlUp).Row + 1
  TS.Rows(2).Copy TS.Range("A" & Rw)
  TS.Range("A3:Q5").Copy
  TS.Range("A" & Rw + 1).PasteSpecial xlPasteFormats
  TS.Range("A" & Rw + 1).PasteSpecial xlPasteValues
  TS.Range("J" & Rw + 1).Value = .Name
  Err.Clear
End If
TR = App.Match(.Name, TS.Range("J:J"), 0) + 3
For FR = 5 To 999
If .Cells(FR, 14) < 0 Then
For FC = 1 To 17
If Not IsNull(TS.Cells(TR, FC).Borders.Value) Then TS.Cells(TR, FC).Borders.Weight = xlThin
TS.Cells(TR, FC) = .Cells(FR, FC)
Next FC
TS.Cells(TR, 19) = .Name
TR = TR + 1
End If
Next FR
Set Rn = TS.Range("B" & Rw + 1 & ":Q" & TR - 1)
If Rng Is Nothing Then
   Set Rng = TS.Range("B3:Q" & TR - 1)
Else
   Set Rng = Union(Rng, Rn)
End If
End With
9 Next FSN
If Not Rng Is Nothing Then
With TS.PageSetup
     .PrintArea = Rng.Address
     .CenterHorizontally = True
     .CenterVertically = False
     .Orientation = xlLandscape
     TS.PrintPreview
End With
End If
Set TS = Nothing: Set FS = Nothing: Set App = Nothing
Set Rn = Nothing: Set Rng = Nothing
End Sub

 

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

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

شكرا استاذ احمد

شكرا استاذ العيدروس

استاذ عيدروس

جعل نطاق الطباعة لكامل البيانات في نطاق واحد بدلا من كل نطاق لحاله