سليم حاصبيا

جرب هذا الماكرو Option Explicit Sub Unique_BY_Dictionary() Rem ====>> Created By Salim Hasbaya On 30/8/2019 If ActiveSheet.Name <> "ورقة1" Then Exit Sub Dim i% Dim obj As Object Range("D2", Range("D1").End(4)).ClearContents Range("e2").ClearContents Set obj = CreateObject("scripting.dictionary") obj.CompareMode = 1 Dim last_ro: last_ro = Cells(Rows.Count, "B").End(3).Row With obj For i = 2 To last_ro If Application.CountIf(Range("H2:H4"), Range("B" & i)) = 0 Then .Item(Range("B" & i).Value) = "" End If Next Range("d2").Resize(.Count) = _ Application.Transpose(.keys) Range("e2") = .Count End With End Sub الملف مرفق No_dup.xlsm

جرب المرفق Info.xlsx

ممكن التعامل مع هذا الملف واختيار 5 ايام متتالية او 7 متفرقة او الكل الاكواد اللازمة Option Explicit Sub test_5Dyas() Rem=====>>> Created By Salim Hasbaya On 30/8/219 Dim str$: str = "غ" Dim cont%, col%, k%: k = 35 Dim i%, x%: i = 3 Dim t%, last_ro% Dim my_text: my_text = "انذار 5 (" Dim X_arr(), m%: m = 1 last_ro = Cells(Rows.Count, 2).End(3).Row Range("Ag5").Resize(last_ro - 4, 7).ClearContents If last_ro < 5 Then Exit Sub For col = 5 To last_ro For x = i To k '========================== If Cells(4, x) = "جمعة" Or Cells(4, x) = "سبت" Then GoTo Next_X End If '========================== If Cells(col, x) = "" Then cont = 0 x = x + 1 End If '========================== cont = cont + IIf(Cells(col, x) <> "", 1, 0) '========================== If cont = 5 Then ReDim Preserve X_arr(1 To m) X_arr(m) = my_text & m & ")" m = m + 1 cont = 0 End If '========================== Next_X: Next x On Error Resume Next t = UBound(X_arr) '========================== If t Then Cells(col, "AG").Resize(1, UBound(X_arr)) = X_arr End If '================================ cont = 0 Erase X_arr: m = 1 Next col End Sub '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub test_7Dyas() Rem=====>>> Created By Salim Hasbaya On 29/8/219 Dim str$: str = "غ" Dim cont%, col%, k%: k = 35 Dim i%, x%: i = 3 Dim t%, last_ro% Dim my_text: my_text = "انذار 7 (" Dim X_arr(), m%: m = 1 last_ro = Cells(Rows.Count, 2).End(3).Row Range("Ag5").Resize(last_ro - 4, 3).ClearContents If last_ro < 5 Then Exit Sub For col = 5 To last_ro For x = i To k '========================== If Cells(4, x) = "جمعة" Or Cells(4, x) = "سبت" Then GoTo Next_X End If '========================== '========================== cont = cont + IIf(Cells(col, x) <> "", 1, 0) '========================== If cont = 7 Then ReDim Preserve X_arr(1 To m) X_arr(m) = my_text & m & ")" m = m + 1 cont = 0 End If '========================== Next_X: Next x On Error Resume Next t = UBound(X_arr) '========================== If t Then Cells(col, "Ak").Resize(1, UBound(X_arr)) = X_arr End If '================================ cont = 0 Erase X_arr: m = 1 Next col End Sub '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Sub all_days() Dim ro%, Col_Num%: Col_Num = 30 Dim xx%, My_count% ro = Cells(Rows.Count, "b").End(3).Row Dim kk%, Mon_array() Dim st$: st = "انذار7(" If ro < 5 Then Exit Sub test_5Dyas For xx = 5 To ro My_count = Application.CountIf(Cells(xx, 3).Resize(1, Col_Num), "غ") My_count = My_count \ 7 If My_count = 0 Then GoTo Next_XX For kk = 1 To My_count Cells(xx, "ak").Offset(, kk - 1) = st & kk & ")" Next Next_XX: Next End Sub الملف مرفق Inzar ALL Days.xlsm

في الخلية M2 انسخ هذه المعادلة واسحب نزولاً =IFERROR(CHOOSE($L2,"ليبي","ليبية"),"") اذا لم تعمل المعادلة معك استبدل الفاصلة " ," بفاصلة منقوطة "; " (حسب اعدادات الجهاز عندك) لتبدو المعادلة بهذا الشكل =IFERROR(CHOOSE($L2;"ليبي";"ليبية");"")

ما قلت لك تم معالجة الامر بالنسبة لخمسة ايام متتالية بالنسبة لانذار الـــ سبعة ايام لا يجوز وضع النتيجة في نفس الخلايا مع نتيجة ماكرو 5 ايام وإلا سيحصل تبادل بحيث تحصل على نتيجة اخر ماكرو تم تشغيله لذلك اقترح ان تكون نتيجة ماكرو 7 ايام في خلايا مستقلة

لا أعلم اذا كان هذا المطلوب بالضبط date_sum.xls

تفضل يا صديقي معادلة معقدة قليلاً لكن تقوم بالواجب =IFERROR(CHOOSE(C5,SUMPRODUCT((WEEKDAY(ROW(INDIRECT(A5&":"&B5)))=6)*1),SUMPRODUCT((WEEKDAY(ROW(INDIRECT(A5&":"&B5)))=6)*1)+SUMPRODUCT((WEEKDAY(ROW(INDIRECT(A5&":"&B5)))=7)*1),SUMPRODUCT((WEEKDAY(ROW(INDIRECT(A5&":"&B5)))=5)*1)+SUMPRODUCT((WEEKDAY(ROW(INDIRECT(A5&":"&B5)))=6)*1)+SUMPRODUCT((WEEKDAY(ROW(INDIRECT(A5&":"&B5)))=7)*1)),"Wrong Input") اذا لم تعمل معك هذه المعادلة استبدل الفاصلة بفاصلة منقوطة لتبدو هكذا =IFERROR(CHOOSE(C5;SUMPRODUCT((WEEKDAY(ROW(INDIRECT(A5&":"&B5)))=6)*1);SUMPRODUCT((WEEKDAY(ROW(INDIRECT(A5&":"&B5)))=6)*1)+SUMPRODUCT((WEEKDAY(ROW(INDIRECT(A5&":"&B5)))=7)*1);SUMPRODUCT((WEEKDAY(ROW(INDIRECT(A5&":"&B5)))=5)*1)+SUMPRODUCT((WEEKDAY(ROW(INDIRECT(A5&":"&B5)))=6)*1)+SUMPRODUCT((WEEKDAY(ROW(INDIRECT(A5&":"&B5)))=7)*1));"Wrong Input") الملف مرفق tajriba.xlsx

تم معالجة الامر بالنسبة لخمسة ايام متتالية الكود Option Explicit Sub test_5Dyas() Rem=====>>> Created By Salim Hasbaya On 29/8/219 Dim str$: str = "غ" Dim cont%, col%, k%: k = 35 Dim i%, x%: i = 3 Dim t% Dim my_text: my_text = "انذار 5 ايام متتابعة (" Dim X_arr(), m%: m = 1 Range("Ag5").Resize(3, 3).ClearContents For col = 5 To 7 For x = i To k '========================== If Cells(4, x) = "جمعة" Or Cells(4, x) = "سبت" Then GoTo Next_X End If '========================== If Cells(col, x) = "" Then cont = 0 x = x + 1 End If '========================== cont = cont + IIf(Cells(col, x) <> "", 1, 0) '========================== If cont = 5 Then ReDim Preserve X_arr(1 To m) X_arr(m) = my_text & m & ")" m = m + 1 cont = 0 End If '========================== Next_X: Next x On Error Resume Next t = UBound(X_arr) '========================== If t Then Cells(col, "AG").Resize(1, UBound(X_arr)) = X_arr End If '================================ cont = 0 Erase X_arr: m = 1 Next col End Sub الملف مرفق Inzar 5 Days.xlsm

لعل هذا ما تريد OfFICE_1.xlsx

في الملف عندك ورقة غريبة لا يمكن حذفها ولا حتى فتحها ولا أعرف كيف اتت الى عندك (خطأ بالـــ System) وهي سبب هذه الرسالة أقترح حذف الملف بالكامل وانشاء ملف جديد مع الكود انظر الى الصورة

كان يجب منذ البداية ارفاق الملف تم معالجة الامر SALIM_DV.xlsm

See this file الاسم الأخير.xlsm

جرب هذا الملف Fathi.xlsx

نموذج اخر عن هذا الموضوع Option Explicit Sub test() Rem===>> created by salim Hasbaya On 28/8/2109 Dim Big_Ro%, Smal_Ro%, t%, i%, x Dim cont%, k%, my_arr(), z1%, z2% Dim BiG_range, Smal_range As Range Dim ro%, My_val Big_Ro = Cells(Rows.Count, 1).End(3).Row Smal_Ro = Cells(Rows.Count, 3).End(3).Row Set BiG_range = Range("A1:A" & Big_Ro) Set Smal_range = Range("C1:C" & Smal_Ro) Smal_range.Interior.ColorIndex = xlNone k = 1 For x = 1 To Smal_Ro '=========================== For t = 1 To Big_Ro z1 = Application.CountIf(Smal_range, Range("A" & t)) z2 = Application.CountIf(Range("a1:a" & t), Range("a" & t)) If z1 = 0 And z2 = 1 Then ReDim Preserve my_arr(1 To k) my_arr(k) = Range("a" & t) k = k + 1 End If Next t On Error Resume Next With Range("C" & x + 1).Validation .Delete .Add xlValidateList, Formula1:=Join(my_arr, ",") End With Err.Number = 0 '============================= My_val = my_arr(1): k = 1: Erase my_arr Next x With Range("C" & x) .Interior.ColorIndex = 6 .Select ' يمكن ازالة الفاصلة العليا من امام السطر التالي 'لادراج اول عنصر من القائمة المنسدلة التي تلي الموجودين ' .Value = My_val End With End Sub '++++++++++++++++++++++++++++++++++++++ Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Dim x_ro% x_ro = Cells(Rows.Count, 3).End(3).Row Dim My_rg As Range Set My_rg = Range("C2:C" & x_ro) If Not Intersect(Target, My_rg) Is Nothing _ And Target.Count = 1 Then test End If Application.EnableEvents = True End Sub الملف للتجربة Smart_DV.xlsm

اذا كنت ترى ان المشكلة قد تم حلها اضغط افضل اجابة لاغلاق الموضوع

عليك برفع الملف موضح عليه المطلوب بكل دقة لكن ربما ينفع هذا المثال الكود Sub ad_val_unique1() Dim Ar(), k%, st$, i%, m% Dim my_rg As Range k = 1 Dim LA%: LA = Cells(Rows.Count, 1).End(3).Row Set my_rg = Range("A2:A" & LA) my_rg.Validation.Delete For i = 2 To LA - 1 For m = i + 1 To LA ReDim Preserve Ar(1 To k) Ar(k) = my_rg.Cells(m - 1) k = k + 1 Next st = Join(Ar, ",") With my_rg.Cells(i - 1).Validation .Delete .Add Type:=xlValidateList, Formula1:=st End With k = 1: Erase Ar: st = "" Next End Sub النموذج مرفق Var_DV.xlsm

ربما ينال الاعجاب هذا الملف Fuction_split_name.xlsm

افترض ان هذا المطلوب (صفحة salim من هذا الملف) Dawam_new_1.xlsx

ممكن هذا المر لكن في هذاه الحالة الافضل ان توقف الماكروين الاخرين لعدم تكبير حجم الملف (بوضع فاصلة عليا عليهما) والاكتفاء بهذا الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$G$5" And Target.Count = 1 Then Me.Cells.Rows.Hidden = False Select Case Range("G5").Value Case "جديد" Range("a19:a22").Rows.Hidden = False Range("a23:a38").Rows.Hidden = True Case Else Range("a19:a22").Rows.Hidden = True Range("a23:a38").Rows.Hidden = False End Select End If Application.EnableEvents = True End Sub

تم معالجة الامر Dawam_new.xlsx

جرب هذا الماكرو مجرد ان تختار اي قيمة من الخلية G5 او الخلية M5 يقوم الماكرو بتنفيذ عمله Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$M$5" Or Target.Address = "$G$5" Then Me.Cells.Rows.Hidden = False Select Case Target.Address Case "$M$5" hide_rows1 Case "$G$5" hide_rows2 End Select End If Application.EnableEvents = True End Sub Sub hide_rows1() Dim my_Rg As Range Set my_Rg = Range("a15:a16") Select Case Range("M5").Value Case "لا": my_Rg.Rows.Hidden = True Case Else: my_Rg.Rows.Hidden = False End Select End Sub Sub hide_rows2() Select Case Range("G5").Value Case "جديد" Range("a19:a22").Rows.Hidden = False Range("a23:a38").Rows.Hidden = True Exit Sub '====================== Case "اعادة" Range("a19:a22").Rows.Hidden = True Range("a23:a38").Rows.Hidden = False Exit Sub '====================== Case "تكميلي" Range("a27:a31").Rows.Hidden = False Range("a19:a22").Rows.Hidden = True Range("a36:a38").Rows.Hidden = True Exit Sub '++=========================== Case "سداد" Range("a27:a31").Rows.Hidden = True Range("a19:a22").Rows.Hidden = True Range("a36:a38").Rows.Hidden = False Case Else End Select End Sub AM_salim.xlsm

ربما يكون الحل Dawam.xlsx

جرب هذاالماكرو Option Explicit Sub test_5() Dim str$: str = "غ" Dim k%: k = 30 Dim cont%, col% Dim i%, x%: i = 3 Range("Ag5").Resize(3, 3).ClearContents For col = 5 To 7 For x = i To k If Application.CountIf(Range(Cells(col, x), Cells(col, x + 7)), str) >= 5 Then cont = cont + 1 Cells(col, "ag").Offset(, cont - 1) = "Ok" & cont x = x + 5 End If Next cont = 0 Next End Sub الملف مرفق للمعاينة Inzar.xlsm

لك ما تريد الصفحة Salim من هذا الملف Variable_DV_new.xlsm

جرب هذا الملف ( من جديد) Variable_DV.xlsm