سليم حاصبيا

اضيفي في الــ Array كل الشيتات التي تريدينها باي لغة تريدين arr = Array("S_1", "S_2", "S_3")

لا اكتب اي كود يتضمن اللغة الغربية (لحسن نسخه ولصقه) لذلك قمت بتغيير اسماء الصفحات التي يعمل عليها الكود الى اللغة الأجنبية (الصفحات الاخرى تم اخفائها وليس حذفها) Option Explicit Sub Get_Data() Dim arr As Variant, itm Dim x As Boolean Dim sh As Worksheet, My_sheet As Worksheet Dim ro%, Col%, m%, k%, i% Dim F_rg As Range arr = Array("S_1", "S_2", "S_3") m = 2 Main.Range("A1").CurrentRegion.Offset(1).Clear For Each itm In arr Set sh = Sheets(itm) ro = sh.Cells(Rows.Count, 1).End(3).Row Col = sh.Cells(1, Columns.Count).End(1).Column For i = 2 To ro Main.Cells(m, 2).Resize(, 2).Value = _ sh.Cells(i, 1).Resize(, 2).Value Set F_rg = sh.Cells(i, 2).Resize(, Col - 1). _ Find("*", after:=sh.Cells(i, 3)) If Not F_rg Is Nothing And F_rg.Column <= Col Then With Main.Cells(m, 4) .Value = F_rg .Offset(, 1) = sh.Name .Offset(, 2) = sh.Cells(1, F_rg.Column) End With End If m = m + 1 Next i Next itm If m > 2 Then With Main.Range("a2:f" & m) .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .InsertIndent 1 .Interior.ColorIndex = 35 .Columns(1) = Evaluate("row(1:" & m - 2 & ")") With .Rows(m - 1) .Cells(1) = vbNullString .Cells(5) = "Sum" .Cells(4).Formula = _ "=SUM(D2:D" & m - 1 & ")" End With End With End If End Sub Yara.xlsm

لا اعلم ابن لخطا عندك لكن عندي تعمل المعادلة بشكل صحيح (الملف مرفق) ربما يجب استبدال الفاصلة "," بفاصلة منقوطة ";" حسب اعدادات الجهاز عندك Example.xlsx

المعادلة المطلوبة في هذه الصورة

=IF(ورقة1!G1325=0,ورقة1!E1325,"")

في هذا السطر من الكود استبدل الرقم 35 الى الرقم 6 S.Cells(i, 1).Resize(, 9).Interior.ColorIndex = 35

جرب هذا الملف Shibl_Find.xlsm

جرب هذا الكود تحتار من الى من حلال الخلايا L2 و K2 تم تضغط الزر Run الصفحة (My_shee لاختيار اسم واحد تضع الخلايا L2 و K2 متساوتين مثلا من 10 الى 10 تعطيك السجل رقم 10 Sub Get_Dta() Dim M As Worksheet, T As Worksheet Dim LrM%, i%, Mn, Mx, k% Set M = Main: Set T = Targ LrM = M.Cells(Rows.Count, 1).End(3).Row T.Range("A2").Resize(LrM, 8).ClearContents If Val(T.Cells(2, "L")) < 2 _ Or T.Cells(2, "L") > LrM Then T.Cells(2, "L") = 2 If Val(T.Cells(2, "K")) < 2 _ Or T.Cells(2, "K") > LrM Then T.Cells(2, "K") = T.Cells(2, "L") + 10 Mn = Application.Min(T.Cells(2, "K"), T.Cells(2, "L")) Mx = Application.Max(T.Cells(2, "K"), T.Cells(2, "L")) T.Cells(2, "K") = Mx T.Cells(2, "L") = Mn T.Cells(2, 2).Resize(Mx - Mn + 1, 7).Value = _ M.Cells(Mn, 1).Resize(Mx - Mn + 1, 7).Value '+++++++++++++++By Choise++++++++++++++++++++++++ ' T.Cells(2, 1).Resize(Mx - Mn + 1).Value = _ ' Evaluate("Row(1:" & Mx - Mn + 1 & ")") T.Cells(2, 1).Resize(Mx - Mn + 1).Value = _ Evaluate("Row(" & Mn & ":" & Mx & ")") '+++++++++++++++++++++++++++++++++++++++++++++++++ End Sub الملف مرفق scorpionehb.xlsm

لقد اقترحت على السائل هذا الأمر في اجابتي الثانية مع وضع الحل المناسب لكنه رفض ذلك

حرب هذا الماكرو (تم ادراج اسماء الصفحات (Code Name اي الأسماء البرمجية) باللغة الأجنبية لعدم ظهور احرف غريبة و غير مفهومة في الكود مما يسهل عملية تسخه ولصقه من جهة و من جهة ثانية لا أحب الكتابة باللغة العربية داخل اي الكود) Option Explicit '++++++++++++++++++++++++++++++++++++ Dim sh As Worksheet Dim LastRow%, ro%, i%, m%, Last% Dim someRange As Range Dim My_Area As Range Dim Signle_cel As Range Dim adr1$, adr2$ Dim Ar(), itm '+++++++++++++++++++++++++++++++++++++ Sub Get_Sheet_name() Dim curt_rg As Range Set curt_rg = Main.Range("A2").CurrentRegion Last = curt_rg.Rows.Count If Last > 1 Then curt_rg.Offset(1).Resize(Last - 1).ClearContents End If i = 0 For Each sh In Sheets If sh.Name <> Main.Name Then Main.Range("A3").Offset(i) = sh.Name ReDim Preserve Ar(i) Ar(i) = sh.Name i = i + 1 End If Next End Sub '+++++++++++++++++++++++++++++++++++++++ Sub lasl_cell() Get_Sheet_name m = 3 For Each itm In Ar adr1 = "": adr2 = "" Set sh = Sheets(itm) ro = sh.Cells(Rows.Count, 1).End(3).Row sh.Range("A3").Resize(ro - 1, 9) _ .Interior.ColorIndex = xlNone Set someRange = Union(sh.Range("A2:A" & ro), _ sh.Range("D2:D" & ro), sh.Range("G2:G" & ro)) For Each My_Area In someRange.Areas For Each Signle_cel In My_Area.Cells If Signle_cel = "" Then GoTo Put_It adr1 = Signle_cel.Address adr2 = Signle_cel.Offset(, 2).Address Next Signle_cel Next My_Area Put_It: If adr1 <> "" And adr2 <> "" Then sh.Range(adr1).Resize(, 3). _ Interior.ColorIndex = 35 With Main.Cells(m, 2) .Value = sh.Range(adr1) .Offset(, 1) = sh.Range(adr2) End With End If m = m + 1 Next itm End Sub OUMALA3_New.xlsm

اذا كانت التواريخ مرتبة تنازليا لا يتناسب اخر تاريخ(Max) مع اخر دفعة

بهذه الطريقة صجيج انك تحصل على اكبر تاريخ لكن !!!! 1- ربما كانت التواريخ في مرتبة تصاعدياً (عتدها لا تكون اخر دفعة) 2- كيف تجد في اي عامود موجود هذا التاريخ؟؟؟؟

لحل هذه المشكلة يجب ان تكون البيانات المطلوبة في عامود واحد (كما في الملف المرفق) و الا لا حل الا بواسطة الـــ VBA OUMALA3_1.xlsx

سبق و قلت الخلايا الحمراء في الغامود D يجب ان تكون فارغة الكود يعمل بكفاءة عالية و انت تستعمل ماكرو اخر غير الماكرو الذي كتبته لك في هذا الملف تم تنزيل ماكرو وحيد الزر الازرق Last_One.xlsm

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

تم معالجة الأمر الخلايا الحمراء في الغامود D يجب ان تكون فارغة ( لأن الماكرو يتعامل مغ الخلايا غير الفارغة في هذا العامود D فقط ) Option Explicit Sub Salim_test() Dim i%, Ro% Dim arr(), Ara As Range Dim Sh As Worksheet Dim dic As Object Dim R_D As Range Set Sh = Sheets("Sheet1") Ro = Sh.Cells(Rows.Count, 3).End(3).Row Set R_D = Sh.Range("D1:D" & Ro).SpecialCells(2, 23) Sh.Range("J2").Resize(Ro, 4).ClearContents arr = Array("Item NO", "Pack Qty", "TOTAL") Set dic = CreateObject("scripting.dictionary") For Each Ara In R_D.Areas For i = 1 To Ara.Rows.Count dic(Ara.Cells(i).Offset(, 2).Value) = _ dic(Ara.Cells(i).Offset(, 2).Value) _ + Val(Ara.Cells(i).Offset(, 3)) Next i With Ara.Cells(1).Offset(-1, 7) .Resize(, 3) = arr .Offset(1, 2) = WorksheetFunction.Sum(dic.items) .Offset(1).Resize(dic.Count, 2) = _ Application.Transpose(Array(dic.keys, dic.items)) .Offset(1, -1).Resize(dic.Count).Value = _ Evaluate("row(1:" & dic.Count & ")") End With dic.RemoveAll Next Ara Set Ara = Nothing: Set Sh = Nothing Set dic = Nothing: Set R_D = Nothing Erase arr End Sub TASALSUL.xlsm

احتصار بسيط للكود المقدم من الاستاذ محي الدين (عسى ان يكون المطلوب) Option Explicit Sub Salim_test() Dim a As Variant, i Dim ar, arr(), x Dim Sh As Worksheet Dim dic As Object x = 1 Set Sh = Sheets("Sheet1") Sh.Range("J1").Resize(10000, 4).ClearContents arr = Array("Item NO", "Pack Qty", "TOTAL") Set dic = CreateObject("scripting.dictionary") For Each ar In Sh.Columns("c:c").SpecialCells(2).Areas a = ar.Offset(1, 3).Resize(ar.Count - 1, 2) For i = 1 To UBound(a) dic(a(i, 1)) = dic(a(i, 1)) + Val(a(i, 2)) Next With Sh.Cells(x, 11) .Resize(, 3) = arr .Offset(1, 2) = WorksheetFunction.Sum(dic.items) .Offset(1).Resize(dic.Count, 2) = _ Application.Transpose(Array(dic.keys, dic.items)) .Offset(1, -1).Resize(dic.Count).Value = _ Evaluate("row(1:" & dic.Count & ")") End With x = x + UBound(a) + 2 dic.RemoveAll Next End Sub nany.xlsm

جرب المعادلة في هذه الصورة

المعادلة كما في الصورة الملف مرفق Ala3.xlsx

أولاً المعادلات الصحيحة دون ظهور عدد كبير من الأرقام بعد الغاصلة (كيف يجب ان تكون) في الصورة ثانياً لم تفهم ما تريد بالضيط (شروط النجاج في كل مادة ام النحاج في كل المواد) Complete.xlsx

هذا الماكرو يقوم بتجديد التكرار باللون الاصفر (العامودين الاول والثاني) Option Explicit 'Excel VBA find duplicates with the scripting dictionary Rem Created By salim hasbaya On 21/2/2021 Sub Find_Dupl() Dim D As Worksheet Dim ar As Variant, Curt_rg As Range Dim i As Long, Rg As Range Dim ro% Set D = Sheets("Data") Set Curt_rg = D.Range("B2").CurrentRegion ro = Curt_rg.Rows.Count If ro = 1 Then Exit Sub Set Curt_rg = Curt_rg.Offset(1).Resize(ro - 1) Curt_rg.Interior.ColorIndex = xlNone ar = D.Cells(2, 2).CurrentRegion.Value With CreateObject("Scripting.Dictionary") .CompareMode = 1 For i = 2 To UBound(ar, 1) If Not .Exists(ar(i, 1) & "*" & ar(i, 2)) Then .Item(ar(i, 1) & "*" & ar(i, 2)) = Empty Else If Rg Is Nothing Then Set Rg = D.Cells(i, 2).Resize(, 2) Else Set Rg = Union(Rg, D.Cells(i, 2).Resize(, 2)) End If End If Next End With If Not Rg Is Nothing Then Rg.Interior.ColorIndex = 6 End If End Sub الملف مرفق Ksaa.xlsm

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

استعمال N(J9) ضروري و ذلك لعدم ورود خطأ في حال كانت الخلية J9 تحتوي على Text وليس رقماً الصورة توضح ذلك

اذا كنت نريد النقريب ما بعد العدد الثالث يعد الفاصلة استعمل في العامود K هذه المعادلة =IF(N(J9)=0,"",ROUND(J9/4,2))

كان يجب رقع ملف للمعالجة لكن اليك هذا النموذج الذي يمنع التكرار في العامودين الأول والثاني (النظاق الأخضر) Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim x%, RG As Range x = Cells(Rows.Count, 1).End(3).Row Set RG = Range("A1:B" & x) Application.EnableEvents = False If Not Intersect(Target, RG) Is Nothing And _ Application.CountA(Range("A" & Target.Row).Resize(, 2)) = 2 Then RG.RemoveDuplicates Array(1, 2) End If Application.EnableEvents = True End Sub الملف مرفق No_dups.xlsm