سليم حاصبيا

تم معالجة الأمر مع تغيير بسيط في تصميم اليوزر New_UNIQ_DATA.xlsm

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

معادلات ممتازة لكنها كثيرة 12 معادلة (كل 6 أعمدة يجب تغييرها) يمكن اختصار الكل الى معادلة واحدة تكتب في الخلية G4 وتسحب ييميناٌ ثم نزولاً =IFERROR(OFFSET(INDIRECT("'"&OFFSET($G$2,,INT((COLUMNS($A$1:A1)-1)/6)*6)&"'!"&"C$"&ROWS($A$1:A5)),,CHOOSE(MOD(COLUMNS($A$1:A1)-1,6)+1,35,36,37,38,39,40)),"") Saef _Extra.xlsx

جرب هذا الملف تم توقيف الماكروات القديمة في الملف لتقييم الماكرو (يمكنك اعادة تشغيلها) وتصغبر جحم الملف من 8 مبغا الى 285 كيلو (اي اكثر من 25 مرة) Mohammed.xlsm

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

الكود الذي يعمل على سطر واحد يستطيع العمل على الالوف منها لذلك ارفع ملفاُ نموذجاَ مختصراَ (دون اسماء حقيقية ) من 10 الى 15 صف لمعالحة الموضوع

استبدل في الكود ما موجود في المربع الأحمر بما بما هو موجود في المربع الأزرق اي احذف الرقم 2 (مع ترك الفاصلة) كما في الصورة ( في مكانين) على كل حال ارفع الملف لاكتب لك كود بسيط جداً حوالي 10 سطور و يمكن اقل

جرب هذا الكود Option Explicit Dim sh As Worksheet Dim Other_sh As Worksheet Dim Rg As Range Dim All_RG As Range Dim lc%, i%, Ro%, Arr(), itm '+++++++++++++++++++++++ Sub creat_shett() Set sh = Sheets("Sheet1") lc = sh.Cells(Rows.Count, 3).End(3).Row For Each Rg In sh.Range("C2:C" & lc) If Rg.Value <> "" Then If Not Application.Evaluate("ISREF('" & Rg.Value & "'!A1)") Then sh.Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = Rg.Value End If End If Next add_data End Sub Sub add_data() Set sh = Sheets("Sheet1") For Each Other_sh In Sheets If Other_sh.Name <> "Sheet1" Then ReDim Preserve Arr(i) Arr(i) = Other_sh.Name i = i + 1 End If Next For Each itm In Arr Set Other_sh = Sheets(itm) With Other_sh Set All_RG = .Range("A1").CurrentRegion Ro = All_RG.Rows.Count If Ro > 1 Then Set All_RG = All_RG.Offset(1).Resize(Ro - 1) All_RG.Clear End If .Range("Z1") = sh.Cells(1, 3) .Range("Z2") = .Name sh.Range("A1").CurrentRegion.AdvancedFilter 2, _ .Range("Z1:Z2"), .Range("A1:d1") .Range("Z1:Z2").Clear End With Next End Sub الملف مرفق Hasan_rady.xlsm

بارك الله بك الرحاء ان تضع في بداية كل كود ما هي مهمته و بذلك تسهل عملية البحث عن كود معين

تسلم اخي أبو الحسن و شكراً لك على هذا العمل بس يا ريت ترفع نسخة عن مكتبتك لاني لا أحتفط بالأكواد التي أضعها (الا القليل منها) حتى يستفيد منها الأخرون

في حال كان عدد الصفوف كبيراً (اكثر من 10 ) وقتها يجب ان نعين الكثير من المتغيرات S1/S2/....... /S20 و أرى ان هذا الأمر يأخذ كود طويل جداَ لذلك اقترح هذا الكود الذي يحدد اوتوماتيكياً عدد الصفوف و يحمعها في Array Option Explicit Sub Free_summation_1() Dim M As Worksheet Dim M_index Dim t%, k% Dim lr% Dim Arr() lr = Sheets("Jan").Cells(Rows.Count, 2).End(3).Row For k = 2 To lr ReDim Preserve Arr(k - 2) Arr(k - 2) = 0 Next Set M = Sheets("Month") M_index = M.Index If M_index = 1 Then Exit Sub If M_index > 12 Then M_index = 13 For t = 1 To M_index - 1 For k = LBound(Arr) To UBound(Arr) Arr(k) = Arr(k) + _ IIf(IsNumeric(Sheets(t).Range("B" & k + 2)), _ Sheets(t).Range("B" & k + 2), 0) Next k Next t M.Range("B2").Resize(UBound(Arr) + 1) = _ Application.Transpose(Arr) End Sub ما أقصده في هذا الملف Moustafa_extra.xlsm

هكذا عمل لا يمكن للمعادلة ان تتحكم به لانه متعلق بموقع الشيت Month والله أعلم يمكن عمل ما تريد بواسطة الماكرو كما في الملف المرفق الكود Option Explicit Sub Free_summation() Dim M As Worksheet Dim M_index Dim first_index%, t% Dim S2#, S3#, S4#, S5#, S6# Set M = Sheets("Month") Dim Arr() M_index = M.Index If M_index = 1 Then Exit Sub If M_index > =13 Then M_index = 13 For t = 1 To M_index - 1 S2 = S2 + IIf(IsNumeric(Sheets(t).Range("B2")), _ Sheets(t).Range("B2"), 0) S3 = S3 + IIf(IsNumeric(Sheets(t).Range("B3")), _ Sheets(t).Range("B3"), 0) S4 = S4 + IIf(IsNumeric(Sheets(t).Range("B4")), _ Sheets(t).Range("B4"), 0) S5 = S5 + IIf(IsNumeric(Sheets(t).Range("B5")), _ Sheets(t).Range("B5"), 0) S6 = S6 + IIf(IsNumeric(Sheets(t).Range("B6")), _ Sheets(t).Range("B6"), 0) Next Arr = Array(S2, S3, S4, S5, S6) M.Range("B2").Resize(UBound(Arr) + 1) = _ Application.Transpose(Arr) End Sub Moustafa.xlsm

Try This Formula in the cell B2 sheet(YTD) and Copy Down =SUM(Jan:Dec!B2) file Included YTD_ Products.xlsx

جرب هذا الكود وترى النتيجة في Sheet2 Option Explicit Sub Split_names() Dim rg As Range Dim i%, Str Sheets("sheet2").Range("B2").CurrentRegion.Clear Set rg = Sheets("sheet1").Range("B2").CurrentRegion For i = 1 To rg.Cells.Count Str = rg.Columns(1).Cells(i) Str = Split(Str, "|") Sheets("sheet2").Cells(i + 1, 2) _ .Resize(, UBound(Str) + 1) = Str Next Sheets("sheet2").Range("B2"). _ CurrentRegion.Columns.AutoFit End Sub الملف مرفق Split_names.xlsm

1- من ايت يأتي لك الاكسل بالورقة رياضيات وهي ليست موجودة ضمن الأوراق 2-يظهر انك تستعمل اصدار قديم من اكسل ليس فيه العامود MM 3- في هذه الحالة يمكن الاستعانة بأي عامود غير MM مثلاُ Z لاحظ الصورة فيصبح الكود بهذا الشكل Option Explicit Sub My_Ad_filter() Dim Rg As Range Dim Cret_rg As Range Dim arr, itm Application.ScreenUpdating = False arr = Array("عربية", "فيزياء", "فرنسية") Set Rg = Sheets("g").Range("A14").CurrentRegion For Each itm In arr With Sheets(itm) .Range("A14").CurrentRegion.ClearContents .Range("Z1") = "المادة" .Range("Z2") = itm Set Cret_rg = .Range("Z1:Z2") Rg.AdvancedFilter 2, Cret_rg, .Range("A14") Cret_rg.ClearContents End With Next Application.ScreenUpdating = True End Sub الملف مرفق H_2611 -2.xls

اذا كانت العناصر في الـــ Array نصوصاً لا لزوم للأقواس في السطر حيث الخطأ (الأ صفر) (حتى وان وضعتها لا مشكلة) كما عليك وضع اسماء الصحفات الـــ Array وليس اي اسماء تخطر على بالك اما مكان الــ Itm في يقية اسطر الكود (بعد سطر الخطأ) تضع الشيء الذي تريد ان تفلتر على اساسه بين قوسين اذا كان نصاً

تستدبل قيم الــ Array بالأسماء (ما ليس رقماً داخل اقواس " " اما الأرقام بدون اقواس) هكذا مثلا arr = Array("سعيد", "أكرم", 3, 4, "Amine", "سليم")

التنسيقات بهذا الشكل و الألوان الباهرة تثقل الملف دون حاجة لها الكود Option Explicit Sub Tansfer_data() Dim Tabl As Range Dim m%, Ro%, x%, k%, LA% Dim B_rg As Range Set Tabl = Source.Range("A5").CurrentRegion Ro = Tabl.Rows.Count If Ro = 1 Then Exit Sub Set B_rg = But.Range("A1").CurrentRegion If B_rg.Rows.Count > 1 Then B_rg.Offset(1).Resize(B_rg.Rows.Count - 1) _ .Interior.ColorIndex = xlNone End If Set Tabl = Tabl.Offset(1).Resize(Ro - 1) x = But.Cells(Rows.Count, 4).End(3).Row + 1 But.Range("D" & x).Resize(Ro - 1, Tabl.Columns.Count).Value = _ Tabl.Value m = Application.CountA(But.Range("D:D")) m = But.Cells(m, 1).Offset(-Ro + 1).Row + 1 For k = 1 To 3 But.Cells(m, k) = Source.Cells(k, 2) Next LA = But.Cells(Rows.Count, 1).End(3).Row If LA > 2 Then But.Range("A2:C" & LA).Resize(, 3) _ .SpecialCells(2).Interior.ColorIndex = 35 End If Tabl.ClearContents End Sub الملف مرفق Azhar.xlsm

تم التغيير في تصميم الأوراق لانها كانت تحتوى على خلايا مدمجة تعيق عمل الكود

جرب هذا الكود Option Explicit Sub My_Ad_filter() Dim Rg As Range Dim Cret_rg As Range Dim arr, itm Application.ScreenUpdating = False arr = Array(1, 2, 3, 4) Set Rg = Sheets("g").Range("A14").CurrentRegion For Each itm In arr With Sheets(itm & "") .Range("A14").CurrentRegion.ClearContents .Range("MM1") = "القسم" .Range("MM2") = itm Set Cret_rg = .Range("MM1:MM2") Rg.AdvancedFilter 2, Cret_rg, .Range("A14") Cret_rg.ClearContents End With Next Application.ScreenUpdating = True End Sub الملف مرفق H_2610.xlsm

لا ضرورة لهذه الأكواد المعقدة للفورم (انظر الى الكود داخل اليوزر) 3 أكواد بسيطة جداً يكفي اكواد بسيطة وسلسلة كما في هذا الملف 1-اضغط على الزر الازرق يطهر لك اليورز 2- أحتر اسم الورقة من الكومبوبوكس 3-اضغط الزر المناسب Jamal.xlsm

لا أعلم اذا كان هذا المطلوب Osama.xlsx

مثال عما أقصده هذا الكود Sub test() Dim sh As Worksheet ActiveWindow.DisplayWorkbookTabs = True For Each sh In Sheets sh.Range("A1") = sh.Name Next ActiveWindow.DisplayWorkbookTabs = False End Sub

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

قم بهذه الخطوات حسب الصورة