khairi ali قام بنشر فبراير 2, 2020 مشاركة قام بنشر فبراير 2, 2020 Tarhil_3iyab.xlsm رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر فبراير 2, 2020 مشاركة قام بنشر فبراير 2, 2020 من باب العرفان بالجميل واحتراماً لشيء يدعى "حقوق الملكية الفكرية" كان يجب عليك ان تذكر من وضع لك الكود الذي تعمل عليه في الملف تم التعديل على الكود كما تريد Option Explicit Sub ABSCENT_new() Application.Calculation = xlCalculationManual Dim K As Worksheet, A As Worksheet Dim Ro_K%, col%, Ro_A%, i%, m%, t%: t = 1 Dim ALL$, ALPHA$, Str$: Str = "غ" ALL$ = " ": ALPHA = " " Set K = Sheets("keab"): Set A = Sheets("arhkeab") Ro_K = K.Cells(Rows.Count, 2).End(3).Row If Ro_K < 5 Then Exit Sub Ro_A = A.Cells(Rows.Count, 2).End(3).Row m = IIf(Ro_A < 5, 5, Ro_A + 1) For i = 5 To Ro_K If Application.CountIf(K.Cells(i, 6).Resize(1, 31), Str) = 0 Then _ GoTo My_next A.Cells(m, 2).Resize(, 2).Value = _ K.Cells(i, 2).Resize(, 2).Value For col = 6 To 36 If K.Cells(i, col) = Str Then ALL = ALL & Day(K.Cells(4, col)) & "-" ALPHA = ALPHA & K.Cells(3, col) & "-" t = t + 1 End If Next col If t > 1 Then With A.Cells(m, 4) .Value = Mid(ALL, 1, Len(ALL) - 1) .Offset(, 1) = Mid(ALPHA, 1, Len(ALPHA) - 1) .Offset(, 2) = t - 1 .Offset(, 3) = K.Cells(2, "T") .Offset(, 4) = Year(Date) End With m = m + 1 End If My_next: t = 1 ALL = " ": ALPHA = " " Next i Application.Calculation = xlCalculationAutomatic End Sub Tarhil_3iyab (2).xlsm 2 رابط هذا التعليق شارك More sharing options...
khairi ali قام بنشر فبراير 2, 2020 الكاتب مشاركة قام بنشر فبراير 2, 2020 استاذ سليم انا اعترف بأن هذا الكود من شغلك انت ولك فائق الشكر وانا أتعلم من حضرتكم ولم اقل اني صاحب هذا الكود استاذ سليم هناك مشكلة صغيرة وهي تغير اتجاة أرقام أيام الغياب مثلا 5-6-16-23 بهذه الطريقة وليس 23-16-6-5 وشكرا رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر فبراير 2, 2020 مشاركة قام بنشر فبراير 2, 2020 انا لم اقل انك انت من كتب الكود حتى و لو لم اكن انا من وضع الكود (أي شخص اخر) يجب ان تذكر صاحبه 2 رابط هذا التعليق شارك More sharing options...
khairi ali قام بنشر فبراير 2, 2020 الكاتب مشاركة قام بنشر فبراير 2, 2020 مشكور استاذ سليم قد ظهرت مشكلة وهي عند تغير الشهر تظهر هذه الرشالة رابط هذا التعليق شارك More sharing options...
أفضل إجابة سليم حاصبيا قام بنشر فبراير 3, 2020 أفضل إجابة مشاركة قام بنشر فبراير 3, 2020 تم معالجة الامر مع بعض التحسينات على الكود Option Explicit Sub ABSCENT_EXTRA() Application.Calculation = xlCalculationManual Dim K As Worksheet, A As Worksheet Dim Ro_K%, col%, NUM%, Ro_A%, x%, i%, m%, t%: t = 1 Dim ALL$, ALPHA$, Str$: Str = "غ" ALL$ = " ": ALPHA = " " Set K = Sheets("keab"): Set A = Sheets("arhkeab") Ro_K = K.Cells(Rows.Count, 2).End(3).Row If Ro_K < 5 Then Exit Sub Ro_A = A.Cells(Rows.Count, 2).End(3).Row m = IIf(Ro_A < 5, 5, Ro_A + 1) NUM = m For i = 5 To Ro_K If Application.CountIf(K.Cells(i, 6).Resize(1, 31), Str) = 0 Then _ GoTo My_next A.Cells(m, 2).Resize(, 2).Value = _ K.Cells(i, 2).Resize(, 2).Value For col = 36 To 6 Step -1 If K.Cells(i, col) = Str Then ALL = ALL & col - 5 & "-" End If Next col For col = 6 To 36 If K.Cells(i, col) = Str Then ALPHA = ALPHA & K.Cells(3, col) & "-" t = t + 1 End If Next col If t > 1 Then With A.Cells(m, 4) .Value = Mid(ALL, 1, Len(ALL) - 1) .Offset(, 1) = Mid(ALPHA, 1, Len(ALPHA) - 1) .Offset(, 2) = t - 1 .Offset(, 3) = K.Cells(2, "T") .Offset(, 4) = Year(Date) End With m = m + 1 End If My_next: t = 1 ALL = " ": ALPHA = " " x = x + 1 Next i With A.Range("b" & NUM).Resize(x, 7) .ClearFormats .InsertIndent 1 .Borders.LineStyle = 1 End With Application.Calculation = xlCalculationAutomatic End Sub Tarhil_3iyab (3).xlsm 2 رابط هذا التعليق شارك More sharing options...
khairi ali قام بنشر فبراير 3, 2020 الكاتب مشاركة قام بنشر فبراير 3, 2020 عمل رائع استاذ سليم مشكور جدا وبارك الله فيك وان شاء الله في ميزان حسانتك 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان