الـعيدروس

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