سليم حاصبيا

جرب هذا الملف عذراً على ازالة التنسيقات ( لا استطيع العمل وسط تنسيقات بالوان فاقعة) اضابير salim.rar

الملف يحتوي على معادلات لا يعرفها هذا الاصدار(من 2007 و ما فوق) جربه على اي جهاز اخر فيه اصدار 2007 و ما بعد و ستلاحظ انه يعمل

هذا لان هناك خلايا مدمجة (مما يعيق عمل الكود) لحل هذه المشاكل استبدل الكود الاول بهذا (يمكنك تفيير الباسورد من داخل الماكرو) الحالي هو 123 Sub MergeMyData1() Dim ws As Worksheet Application.ScreenUpdating = False Application.Calculation = xlCalculationManual If ActiveSheet.Name <> "تسوية" Then Exit Sub On Error Resume Next With Sheets("تسوية") .Unprotect Password:="123" .Range("c13", Range("c" & Rows.Count).End(xlUp)).ClearContents .Range("az1", Range("az" & Rows.Count).End(xlUp)).ClearContents .Range("h2:at2").ClearContents End With '======================================= Dim arr() arr = Array("1", "2", "4", "5", "6", "8") For i = LBound(arr) To UBound(arr) Sheets("تسوية").Cells(2, kk + 8) = arr(i) Set ws = Sheets(arr(i)) ws.Range("b13", ws.Range("b" & ws.Rows.Count).End(xlUp)).Copy Sheets("تسوية").Range("az" & Rows.Count).End(xlUp).Offset(1) kk = kk + 1 Next Sheets("تسوية").Range("c13", Range("c" & Rows.Count).End(xlUp)).ClearContents With Sheets("تسوية").Range("az1", Range("az" & Rows.Count).End(xlUp)) .sort Key1:=Range("az1"), _ Order1:=xlAscending, _ Header:=xlNo, _ OrderCustom:=1, _ MatchCase:=False, _ Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal End With Sheets("تسوية").Range("az1", Range("az" & Rows.Count).End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo Sheets("تسوية").Range("az1", Range("az" & Rows.Count).End(xlUp)).SortSpecial Sheets("تسوية").Range("az1", Range("az" & Rows.Count).End(xlUp)).Cut Sheets("تسوية").Range("c13") fil_Month_number Sheets("تسوية").Range("c12") = "أسماء السادة الموظفين" Sheets("تسوية").Protect Password:="123" Application.ScreenUpdating = True Application.Calculation = xlAutomatic End Sub

تقضل اخي تم معالجة الامر تختار الاوراق من داخل الكود( 1 fil_Month_number & MergeMyData ) تسوية الضرائب salim special.rar

جرب هذا الملف ZAKI salim.rar

بقي هذا الكود للاختيار Sub sheck() Range("a1:H8").Interior.ColorIndex = xlNone For i = 1 To 8 k = i Mod 2 For j = 1 To 8 m = j Mod 2 If k = m Then Cells(i, j).Interior.Color = 255 Next Next End Sub

في الاثنين معاُ

ربما هذا الكود يقوم بالمطلوب Sub sheck() Range("a1:H8").Interior.ColorIndex = xlNone For i = 1 To 8 k = i Mod 2 For j = 1 To 8 m = j Mod 2 If k = m Then Cells(i, j).Interior.Color = 255 Next Next End Sub

يمكنك استعمال هذا الماكرو لتحديد الاوراق المطلوبة (داخل الـــ Array) ملاحظة:يجب ادراج الاسماء الحقيقية للصفحات مثلاً لو ان اسم الصفحة Salim يجب كتابة "Salim" Sub copy_sheet() Dim arr() arr = Array("Sheet1", "Sheet2", "Sheet4", "Sheet5", "Sheet6", "Sheet8") For i = LBound(arr) To UBound(arr) 'Sheets(arr(i)).copy 'or Sheets(arr(i)).select etc..اكتب الكود هنا Next End Sub

اي اصدار من اكسل تستعمل

اخي خالد تم وضع الكود المناسب بالنسبة للموظفين (دون تكرار) وكل واحد منهم عدد الاشهر بالسنبة لباقي الجدول اظن ان ذلك ليس بالامر الصعب (مجرد نسخ و لصق من اي ورقة اتجاه الاسم المناسب) لم افعل ذلك لضيق الوقت تسوية الضرائب salim.rar

عسى ان ينال الاعجاب Allah_Akbar.rar

قم بهذا التعديل البسيط على الماكرو Application.DisplayAlerts = True Sheets("الاصل").Select i = InputBox("How many copies do you what?", "Salim Ask You") If i > 15 Then i = 15 ' اضف هذا السطر على الكود للحصول عل الشرط اللازم بعد الرسالة مباشرة Application.ScreenUpdating = False

هذا لان حجم الخط كبير عليك اما تصغيره او تكبير عرض الاعمدة لا حظ المرفق كشف تجميعي salim2.rar

لم تظهر الصورة

جرب هذا الملف الماكرو يعمل فيالصفحة الرئيسية فقط نسخ أوراق salim.rar

ممكن ان يكون المطلوب الصفحة رقم 2 كشف تجميعي salim1.rar

تفضاي اختي الفاضلة Temlet1.rar

جرب هذا الملف كلما اردت التغيير اضغط على الزر F9 rand 3alamat.rar

انا لا افهم ما الحاجة الى كتابة هذين السطرين Range("a1").Select ActiveCell.Offset(1, 0).Select ما دام تسطيع ان تستبدلها بكلمتين Range("a2").Select

اليكم هذا الكود (لرسم خط النهاية مع التلوين) لم اتقيد بعرض الاعمدة لانها اصبحت من الامور المعروفة Sub talween() Dim i As Date, k,lastrow As Integer lastrow = Cells(Rows.Count, 1).End(3).Row Range("a1:c" & lastrow).Interior.ColorIndex = xlNone Range("a1:c" & lastrow).Borders.LineStyle = xlNone k = 2 Do Until k > lastrow + 1 If Month(Range("a" & k)) Mod 2 = 1 Then Range(Cells(k, 1), Cells(k, 3)).Interior.ColorIndex = 20 If Month(Cells(k, 1)) <> Month(Cells(k + 1, 1)) Then Range(Cells(k, 1), Cells(k, 3)).Borders(xlEdgeBottom).LineStyle = xlContinuous End If End If k = k + 1 Loop End Sub

تعديل بسيط على الكود (يجعله اسرع) مجرد ان يتم التلوين نخرح من Loop ليست هناك حاجة لتكملتها الى الرقم 12 Sub Rectangle1_Click() Dim i As Date Range("a1:c500").Interior.ColorIndex = xlNone Range("a2").Select Do Until ActiveCell.Value = "" For j = 1 To 12 Step 2 i = ActiveCell.Offset(0, 0).Value If Month(i) = j Then Range(ActiveCell, ActiveCell.End(xlToRight)).Interior.ColorIndex = 20 Exit For ' add this very small line to the code End If Next j ActiveCell.Offset(1, 0).Select Loop End Sub

رجاءً ارفع الملف نفسه وليس صورة و ذلك للتعامل معه بشكل افضل ربما الحالة هذه ليس بحاجة الى كود يكفي النتسيق الشرطي (مرفق مثال) Talween_Month.rar

ممكن يكون المطلوب Temlet.rar

جرب هذا الملف اقساط salim.rar