الـعيدروس

السلام عليكم جرب المرفق 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