الـعيدروس

السلام عليكم

جرب المرفق

Ali_Tst _1.xlsm

من الصور المرفقه من قبلك

كل الداتا لشهر 1 فقط لايوجد شهر 2

السلام عليكم

تم بالمرفق

افضل عدم استخدام التنسيقات الشرطية

اذا تريد ملف عملي ابعد عن التنسيقات 

والالوان لانها مع الوقت ستسبب لك بطئ في الملف

بإمكانك استخدام تقارير لاي بيانات تريدها 

وباقي الطلبات ان شاء الله اجد الوقت وابشر

او بإمكان الاساتذة الافاضل يدلو بدلوهم ليتم ملفك

كما ترجو وزيادة لاني حاليا مسافر وسأعود قريباً ان شاء الله

في امان الله

برنامج المعتمرين _A4.xlsm

اخ ايهاب 

هل تريد جميع الصفحات في مدى واحد

ام كل ورقة في صفحة منفردة ؟

اذا كان طلبك صفحة منفردة فالكود

السابق بيعمل معك تمام

تأكد اخ احمد غير صحيح ماتقول

ارفق مثال لتجربة الكود

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

لنرى اين الخلل بالضبط 

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

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

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

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

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

تفضل شرح مبسط في الكود

تم انشاء جدول الذي اسمة الجدول3 في الشيت

A_2.xlsm

السلام عليكم

بعد اذن استاذنا ابو تامر

جرب المرفق

CONSULTATION_A.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

السلام عليكم

مالذي تريد عمله بالضبط

المرفق به طلبك بخصوص الاختيار

A_1.xlsm

عبر خاصية  Alignment

تم التعديل على المرفق تفضل

برنامج المعتمرين _A3.xlsm

ولك مثل دعائك اضعاف اخ بشير

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

بحيث الحلقة تمشي فقط على الخلايا الفارغة في نطاق البيانات

والتي تعتبر افتراضيا فيها دمج

Sub Ali_Merg()
Dim C_Rng As Object
Dim A, B
Application.ScreenUpdating = False
For Each C_Rng In Application.ActiveSheet.Cells.SpecialCells(xlCellTypeBlanks)
    With C_Rng
        If .MergeCells Then
        A = .MergeArea.Address: B = .Value
            .UnMerge: Range(A).Value = B
        End If
    End With
Next
Application.ScreenUpdating = True
End Sub

تفضل

تأكد من المخرجات

واذا ظهرت لديك اخطاء او ملاحظات بالخدمة

ملاحظة ادخال نوع السكن حاول الادخال عبر القائمة

لكي لايظهر لديك اختلال بتقرير التسكين

برنامج المعتمرين _A3.xlsm

السلام عليكم

جرب المرفق

الشهر تحط رقم 1 او 2 وهكذا

Ali_Tst.xlsm

جرب هذا الكود

بعد اذن الاساتذه الافاضل

Dim Ar()
Dim i
Private Sub Merg_Ali()
Dim C As Range
Dim A As String
Dim B
Sp False
Erase Ar: i = 0
For Each C In ActiveSheet.UsedRange.Cells
If C.MergeCells Then
If i >= 1 Then
If Ar(1, i) = C.MergeArea.Address Then GoTo nx
End If
i = i + 1
ReDim Preserve Ar(1 To 2, 1 To i)
A = C.MergeArea.Address: B = C.Value
Ar(1, i) = A: Ar(2, i) = B
nx:
C.UnMerge
End If
Next
Sp True
If i Then Ar = Application.Transpose(Ar)
End Sub
Private Sub Ad(A)
Sp False
For x = LBound(A, 1) To UBound(A, 1)
    Range(A(x, 1)) = A(x, 2)
Next
Sp True
End Sub
Sub Ali_Mr()
Merg_Ali
If i Then Ad Ar: Erase Ar: i = 0
End Sub
Private Function Sp(Bl As Boolean)
With Application
    .ScreenUpdating = Bl
    .EnableEvents = Bl
End With
End Function

السلام عليكم

جرب المرفق ان شاء الله يفي بالغرض

برنامج المعتمرين _A2.xlsm

وعليكم السلام

ارفق ملف وعليه توضيح طلبك

معذره لم يتم التعديل بالشكل الصحيح

اعد تنزيل مرفق اخر مشاركة

السلام عليكم

تفضل اخي المرفق

غياب_A7 مع الغياب بعذر.xlsm

السلام عليكم

حاولت احسن من ملفك

اتمنى تجربة التعديلات او بإمكانك استخدام طريقتك

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

وبخصوص التقارير بالامكان استخراج تقارير

متعدده اعطني تفاصيل للتقارير وسيتم التعديل

الموجود في المرفق فورم للتقارير عام من اعمال

الاستاذ الجليل والقدير خبور خير حفظه الله ورعاه

عدلت عليه تعديلات بسيطه امل انا تفيدك في ملفك

في امان الله

برنامج المعتمرين _A1.xlsm

السلام عليكم

جرب المرفق

غياب_A6 مع الغياب بعذر.xlsm

وضحت الكثير شكرا

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

هل بكل صفحة رحلة ام كيف

هون يارجل لامشكلة الا ولها حل

مانوع الويندوز الذي لديك 7 او 10