سليم حاصبيا

ملف الكليندر غير موجدود عندي

تم معالجة الأمر فقط استبدال ollsheets بـــ ALL (في القوائم المنسدلة) takrir yara_with ALL.xlsm

هو صعب جداً حذف Oll sheets من القوائم المنسدلة ؟؟؟؟ اصلاً ضعي الاوراق التي تريدين التعامل معها في القوائم المنسدلة

جربي هذا الماكرو Option Explicit Dim Main As Worksheet Dim sh As Worksheet Dim max_ro%, i%, col, arr(), m% Dim st$, Ro%, k%, s#, x%, itm Dim date1 As Date, date2 As Date '======================= Sub Initiallize() For Each sh In Sheets If sh.Name <> "TAkrir" Then sh.Range("C5:J500").Interior.ColorIndex = xlNone End If Next End Sub Sub Extract_negative() Set Main = Sheets("TAkrir") Main.Range("B3:B8").ClearContents If Main.Range("B2") = vbNullString Then Exit Sub If Not IsDate(Main.Range("E3")) Or _ Not IsDate(Main.Range("F3")) Then Exit Sub Set sh = Sheets(Main.Range("B2") & "") date1 = Application.Min(Main.Range("e3:f3")) date2 = Application.Max(Main.Range("e3:f3")) ReDim arr(1 To 6) For i = 3 To 8 arr(i - 2) = Main.Cells(i, 1) Next max_ro = sh.Cells(Rows.Count, 1).End(3).Row k = 3 For Each itm In arr For x = 5 To max_ro If sh.Cells(x, 1) >= date1 And sh.Cells(x, 1) <= date2 Then If sh.Cells(x, itm) > 0 Then sh.Cells(x, itm).Interior.ColorIndex = 35 End If s = s + IIf(sh.Cells(x, itm) < 0, _ sh.Cells(x, itm), 0) End If Next x Main.Cells(k, 2) = IIf(s = 0, "", s) s = 0 k = k + 1 Next itm End Sub '++++++++++++++++++++++++++++++++++ Sub Extract_Positive() Set Main = Sheets("TAkrir") Main.Range("C3:C8").ClearContents If Main.Range("C2") = vbNullString Then Exit Sub If Not IsDate(Main.Range("E3")) Or _ Not IsDate(Main.Range("F3")) Then Exit Sub Set sh = Sheets(Main.Range("C2") & "") date1 = Application.Min(Main.Range("e3:f3")) date2 = Application.Max(Main.Range("e3:f3")) ReDim arr(1 To 6) For i = 3 To 8 arr(i - 2) = Main.Cells(i, 1) Next max_ro = sh.Cells(Rows.Count, 1).End(3).Row k = 3 For Each itm In arr For x = 5 To max_ro If sh.Cells(x, 1) >= date1 And sh.Cells(x, 1) <= date2 Then If sh.Cells(x, itm) < 0 Then sh.Cells(x, itm).Interior.ColorIndex = 6 End If s = s + IIf(sh.Cells(x, itm) > 0, _ sh.Cells(x, itm), 0) End If Next x Main.Cells(k, 3) = IIf(s = 0, "", s) s = 0 k = k + 1 Next itm End Sub '++++++++++++++++++++++++++ Sub Get_all() Initiallize Extract_negative Extract_Positive End Sub الملف مرفق takrir yara.xlsm

المعادلة الثّانية =IF(COUNTIF(الجدول1[القيمة2],11),"X","Y")

هذه المعادلة =COUNTIF(الجدول1[الفلز],"T1")>0 =COUNTIF(الجدول1[القيمة2],11)>0

اتبع الخطوات التالية حسب الصورة

الكود ليس له علاقة بلون التاب فقط يتعاطى مع الشيتات التي اسمها يحتوي على Under score اذا اردتي ان يقوم الماكرة بفحص الشيت الذي اسمه ِAny sheet مثلاً اجعلي اسمه Any_sheet الاسما تدرج جميعها (المكرر مرة واحدة) اذا اردت اضافة اللون الى الشروط يجب اضافة شرط واحد على الكود كما في الصرورة

هذا الملف مع اسماء الشيتات حيث يتواجد كل عنصر مع مجموع كل شيت على حدة Yara_data_With_count.xlsm

1-سبق و قلت لك في موقع اخر الاسماء بسيطة و غير معقدة ( التفتيش عن اسم بسيط للتأكد من عمل الماكرو يصبح امراً سهلاً) و اذا نجح الماكرو تضعيتن الاسماء التي تريدينها 2- اي شيت تريدين ان يشمله الماكرو يجب ان يحتوي اسمه على "_" "Under Score" كما في الملف المرفق 3- لا لزوم لأعداد كبيرة 1458.1587 في البداية فقط يكفي اعداد بسيط من 1 الى 10 للتأكد من عمل الماكرو و اذا نجح الماكرو تضعيتن الأرقام التي تريدينها 4 - لا حاجة لأربع صفحات لاخنبار الماكرو (يكفي صفحتين) و اذا نجح الماكرو تضعيتن ما تريدين من صفحات Option Explicit Sub My_Total() Rem Created By Halim Hasbaya On 15/7/ 2020 Dim Main As Worksheet Dim sh As Worksheet Dim arr(), m%, itm, x%, k% Dim Ro%, S#, ky Dim Dic As Object Application.ScreenUpdating = False m = 1 Set Main = Sheets("SUMOLL") Main.Range("a2").Resize(10000, 2).Clear Set Dic = CreateObject("Scripting.Dictionary") For Each sh In Sheets If InStr(sh.Name, "_") Then ReDim Preserve arr(1 To m) arr(m) = sh.Name m = m + 1 End If Next If m = 1 Then GoTo Thank_You For Each itm In arr Set sh = Sheets(itm) Ro = sh.Cells(Rows.Count, 1).End(3).Row For x = 2 To Ro - 2 Step 2 S = Application.Sum(sh.Cells(x + 1, 2).Resize(, 5)) Dic(sh.Cells(x, 1).Value) = Dic(sh.Cells(x, 1).Value) + S Next x Next itm k = 2 If Dic.Count = 0 Then GoTo Thank_You For Each ky In Dic.keys With Main.Cells(k, "A") .Value = ky .Offset(1) = "TOTAL" .Offset(1).Resize(, 2). _ Interior.ColorIndex = 20 .Offset(1, 1) = Dic(ky) End With k = k + 2 Next ky With Main.Range("A" & k + 1) .Value = "All Sum" .Offset(, 1).Formula = _ "=SUM(B2:B" & k - 1 & ")" .Resize(, 2).Interior.ColorIndex = 8 End With With Main.Range("A2:B" & k + 1) .Borders.LineStyle = 1 .InsertIndent 1 .Value = .Value With .Font .Size = 14: .Bold = True End With End With Thank_You: Set Main = Nothing: Set sh = Nothing Set Dic = Nothing: Erase arr Application.ScreenUpdating = True End Sub الملف مرفق(عدد 2) الأول حسب رغبتك والثاني ما أراه مناسباً اختاري ما تريدين (مع ابداء الرأي) Yara_data.xlsm Yara_data_1.xlsm

رائع و خقيقة مهندس كنت افكر بهكذا معادلة و قد وجدتها قبلي

أعتذر قلت رأيي بدون ان أجرب و كنت أعتقده صائباً انت هنا تضرب 59% بالرقم 2 والنتيجة 1.18 المفروض 118 ( يمكن ضرب النتيجة في 100) =H4*200

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

جرب هذا الماكرو (ينقل البيانات بدون تكرار) من اصفحة الاولى الى اثانية) Option Explicit Sub Get_data() Dim S As Worksheet, T As Worksheet Dim ro%, x%, Dic As Object Dim st, ky, m% Set S = Sheets("Source") Set T = Sheets("Target") Set Dic = CreateObject("Scripting.Dictionary") If T.Range("B1").CurrentRegion.Rows.Count > 1 Then _ T.Range("B1").CurrentRegion.Offset(1). _ Resize(T.Range("B1"). _ CurrentRegion.Rows.Count - 1).ClearContents ro = S.Cells(Rows.Count, 2).End(3).Row For x = 2 To ro If S.Cells(x, 2) <> vbNullString Then st = Application.Transpose(S.Cells(x, 2).Resize(, 5)) st = Application.Transpose(st) st = Join(st, "*") Dic(S.Cells(x, 2).Value) = st End If Next For Each ky In Dic.keys T.Cells(m + 2, 1) = m + 1 T.Cells(m + 2, 2).Resize(, _ UBound(Split(Dic(ky), "*")) + 1) = _ Split(Dic(ky), "*") m = m + 1 Next Set S = Nothing: Set T = Nothing Set Dic = Nothing End Sub الملف مرفق mhmd83.xlsm

معادلة جيدة لكنها تعطي النتيجة نصوصاً (لا يمكن عمل معادلات حسابية عليها)

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

بالرغم من انك لم ترفع بيانات في ملف (امر مخالف لقوانين المنتدى) اليك هذا النموذج Abou_yousef.xlsm

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

اللهم اغفر لها و ارحمها و أدخلها فسيح جناتك إنا لله و إنا إليه راجعون

Try This File Amen_Bkr.xlsm

كبداية يمكن تجربة هذا الملف 1-- الضغط على اي خلية خضراء في الشيت "Data " يذهب بك فوراً الى الورقة المطلوبة 2- الضغط على زر " Add_sheets" يضيف صفحات جديدة (باسماء الجنسيات الجديدة غير الموجودة) اذا كانت الجنسية لها صفجة يتغاضى الكود عنها 3- الضغط غلى الخلية "D1 " من أي صفحة يعيدك الى صفحة "Data" Disribution_Om_Hz_super.xlsm

سيق وقلت 1- اسماء الشيتات باللغة الأجنبية 2- لا ضرورة لأكثر من 20 صف ( و ذلك لمتابعة عمل الكود) لأن الكود الذي يعمل على صف واحد يمكنه العمل على الوف الصفوف 3-ضعي النتائج المتوقعة في صفحة مستقلة صفحة "Resultt" من هذا الملف Disribution_Om_Hz.xlsx

تم معالجة الأمر Option Explicit Sub Fill_data() Dim i%, t% Dim Rg As Range t = 2 With Sheets("data") Set Rg = .Range("A1").CurrentRegion If Rg.Rows.Count > 1 Then _ Rg.Offset(1).Resize(Rg.Rows.Count - 1).Clear For i = 2 To Sheets.Count If Sheets(i).Name <> "data" Then .Cells(t, 1) = Sheets(i).Name .Cells(t, 2).Resize(, 5).Value = _ Sheets(i).Cells(4, 5).Resize(, 5).Value t = t + 1 End If Next i With .Cells(t, 1) .Value = "Sum" .Offset(, 1).Resize(, 5).Formula = _ "=SUM(B2:B" & t - 1 & ")" .Resize(, 6) _ .Interior.ColorIndex = 6 End With Set Rg = .Range("A1").CurrentRegion If Rg.Rows.Count > 1 Then Set Rg = Rg.Offset(1).Resize(Rg.Rows.Count - 1) With Rg .Borders.LineStyle = 1 .InsertIndent 1 .NumberFormat = "#,##.00" With .Font .Bold = 1: .Size = 14: End With .Value = .Value End With End If End With End Sub الملف مرفق Abo_Hasn.xlsm

جرب هذا الملف للانتقال من تكست بوكس الى اخر استعمل Tab او Enter Amine.xlsm