سليم حاصبيا

ما قمت بعمله يؤثر فعلاً جرب ان تمسح الصنف 10 مثلا من صفحة الاصناف وقم بتنفيذ الماكرو سترى ان الصنف 10 الذي حذفته ما زال في الجدول يصفحة المبيعات

أي صنف تزيده او تعدل قيمته يظهر في النتيجة طيعاً بعد تنفيذ الكود بالضغط على الزر ملاحظة الكود يتوقف عن العمل عند اي صف فارغ في شيت الاصناف لذلك لا تترك اي فراغ بين البيانات و اذا اردت حذف صنف من الاصناف عليك حذف (الصف او الصفوف) بالكامل لا لزوم لترتيت الاصناف لان الكود لا ينظر الى المكرر مع انه يقوم بجمع القيم للمكررين مثلا يمكن في اخر صف ادراج الصنف1 و بعده صنف 50 ثم صنف 4 الخ....

كود جديد بقوم بما تريده تم تغيير اسماء الضفحات لسببين 1- لا أطيق العمل بالكود مع اللغة العربية لصعوبة اتجاهات الكتابة (تارة من الشمال اى اليمين وطوراً بالعكس) 2-سهولة نسخ الكود بدون ان تظهر حروف غريبة) Option Explicit Sub Give_data() Dim Dict As New Dictionary Dim Itm#, i%: i = 2 Dim K Dim SA As Worksheet: Set SA = Sheets("Salim") Dim Mab As Worksheet: Set Mab = Sheets("Mabi3at") Dim X#: X = Application.CountA(Mab.Range("b:b")) With SA.Range("A4").Resize(X) .ClearContents .Offset(, 6).ClearContents End With Do Until Mab.Range("b" & i) = vbNullString K = Mab.Range("b" & i): Itm = Mab.Range("d" & i) If Not Dict.Exists(K) Then Dict.Add K, Itm Else Dict(K) = Dict(K) + Itm End If i = i + 1 Loop With SA.Range("a4").Resize(Dict.Count) .Value = Application.Transpose(Dict.Keys) .Offset(, 6).Value = Application.Transpose(Dict.Items) End With Dict.RemoveAll End Sub الملف SUM_WITH DICTIONARY.xlsm

اي يعني لما بيكون المجموع صفر يفترض ان يضع صفر على كل حال اذا كنت لا تريد الصفر يمكن التعديل وذلك باضافة شيء بسيط على سطر واحد بالكود ( ما بين اشارات +++++) Option Explicit Sub sum_if_by_code() Application.ScreenUpdating = False If ActiveSheet.Name <> "الاصناف" Then GoTo Exit_Sub Dim SH_Mab As Worksheet: Set SH_Mab = Sheets("المبيعات") Dim SH_Asnaf As Worksheet: Set SH_Asnaf = Sheets("الاصناف") Dim Rg_Mab As Range Dim Rg_Asnaf As Range Dim My_cel_Mab As Range Dim My_cel_Asnaf As Range Dim m%: m = 0 SH_Mab.Select Set Rg_Mab = SH_Mab.Range("b2", Range("b1").End(4)) SH_Asnaf.Select SH_Asnaf.Range("G4", Range("G3").End(4)).ClearContents Set Rg_Asnaf = SH_Asnaf.Range("a4", Range("a3").End(4)) For Each My_cel_Asnaf In Rg_Asnaf For Each My_cel_Mab In Rg_Mab If My_cel_Asnaf = My_cel_Mab And _ IsNumeric(My_cel_Mab.Offset(, 2)) Then _ m = m + My_cel_Mab.Offset(, 2) Next Rem ++++++++++++++++++++++++++++++++++++++++++++++ My_cel_Asnaf.Offset(, 6) = IIf(m = 0, vbNullString, m) Rem++++++++++++++++++++++++++++++++++++++++++++ m = 0 Next Exit_Sub: Application.ScreenUpdating = True End Sub

لم افهم شيء من ملفك النطاق A1:Ak2 Activesheet يحتوي عل خلايا فارغة عندك مشكلة في الخلايا المدمجة (علة العلل للعمل بالاكواد) غير ذلك تريد تنفيذ ماكرو على Activesheet في هذه الحالة الماكرو سوف يعمل على الشيت النشطة حتى وان كانت غير المطلوبة لذا دائماً قم بتحديد الشيت المعني بالأمر

لاكتشاف الخطأ يجب تشغيل الكود على الملف مباشرة لذا قم بتحميل الملف او جزء منه اذا كان كبيراً

ممكن هذا الكود بدون SumIf Option Explicit Sub sum_if_by_code() Application.ScreenUpdating = False If ActiveSheet.Name <> "الاصناف" Then GoTo Exit_Sub Dim SH_Mab As Worksheet: Set SH_Mab = Sheets("المبيعات") Dim SH_Asnaf As Worksheet: Set SH_Asnaf = Sheets("الاصناف") Dim Rg_Mab As Range Dim Rg_Asnaf As Range Dim My_cel_Mab As Range Dim My_cel_Asnaf As Range Dim m%: m = 0 SH_Mab.Select Set Rg_Mab = SH_Mab.Range("b2", Range("b1").End(4)) SH_Asnaf.Select SH_Asnaf.Range("G4", Range("G3").End(4)).ClearContents Set Rg_Asnaf = SH_Asnaf.Range("a4", Range("a3").End(4)) For Each My_cel_Asnaf In Rg_Asnaf For Each My_cel_Mab In Rg_Mab If My_cel_Asnaf = My_cel_Mab And _ IsNumeric(My_cel_Mab.Offset(, 2)) Then _ m = m + My_cel_Mab.Offset(, 2) Next My_cel_Asnaf.Offset(, 6) = m m = 0 Next Exit_Sub: Application.ScreenUpdating = True End Sub

اين ذهب الماكرو الذي قمت انا بانشائه ===> لا لزوم له تم مسحه هل الماكرو الذي احدثته انت يتولى هذه المهمه اضافة الى مهمة انشاء صفحة جديدة ===> بالطبع هذه مهمته 1- اذا كان عدد الصفوف المملوءة في الشيت الاخير اقل من 11 يتم اضافة ما تريد الى اول صف فارغ في نفس الصفجة حتى يصل عدد الصفوف الى 11 2- و اذا كان عدد الصفوف المملوءة في الشبت الاخير يساوي 11 يتم ادراج شيت جديد الذي يأخد اسم الشيت الذي قبله زائد واحد ويذلك يكون هذا الشيت قد اصبح بدوره اخر شيت و تتم اضافة ما تريد اليه ابتداء من الصف الثاني حتى الرقم 11 ووهكذا دواليك

جرب هذا الماكرو (تم تغيير اسماء الصفحات لحسن عمل الكود بالنسبة لنسخه (حتى لا تظهر احرف غريبة) Sub Salim_Macro() Rem Created On 31/5/2019 By Salim Hasbaya Application.ScreenUpdating = False Dim New_ro% Dim t%: t = Sheets(Sheets.Count).Index Dim target_sh As Worksheet Dim M_sh As Worksheet Set M_sh = Sheets("main") Dim last_ro% laste_ro = Sheets(t).Cells(Rows.Count, 1).End(3).Row Select Case laste_ro Case 11 Set target_sh = Sheets.Add(after:=Sheets(t)) ActiveSheet.Name = "MY_sh" & t - 1 M_sh.Range("a1:c1").Copy ActiveSheet.Range("a1") End Select Set target_sh = Sheets(Sheets.Count) New_ro = target_sh.Cells(Rows.Count, 1).End(3).Row + 1 M_sh.Range("a2:c2").Copy _ target_sh.Cells(New_ro, 1) M_sh.Select Application.ScreenUpdating = True End Sub 33_salim.xlsm

هذه المعادلة =TEXT(E2,"0000000")&"-"&TEXT(D2,"0000000")

كل صفحة من اكسل 2010 تحتوي على: 1,048,576 صف (اكثر من مليون صف ) 16,384 عامود (اكثر من 16000 عامود) اي 1048576 × 16384=17,179,869,184 خلية (اكثر من 17 مليار خلية ) اكثر بثلاث مرات عدد سكان الارض هل تستطيع أن تملأها بيانات للتأكيد هذا الماكرو Option Explicit Sub Cells_numbe() Dim x, y, z x = ActiveSheet.Rows.Count y = ActiveSheet.Columns.Count z = x * y Cells(1, 1) = "Rows Count" Cells(1, 2) = "Columns Count" Cells(1, 3) = "Cells Count" Cells(2, 1) = x Cells(2, 2) = y Cells(2, 3) = z End Sub

ارجو رفع ملف بالموضوع كي يستطيع الاساتذة المساعدة مثلاُ ما هو التقدير A+ اقصد العلامة المطلوبة كي يحصل الطالب على A+ نفس الشيء بالنسبة B C C-

جرب هذا الماكرو Sub FIL_combo() Dim sh As Worksheet Dim obj As Object Set obj = _ CreateObject("System.Collections.Arraylist") For Each sh In Worksheets If sh.Name <> "Main" Then With sh.Range("b2") obj.Add .Value & " " _ & .Offset(, 1).Value End With End If Next Sheets("Main").ComboBox1.List = _ Application.Transpose(obj.toarray) obj.Clear: Set obj = Nothing End Sub Rem===============>> Salim Private Sub ComboBox1_DropButtonClick() FIL_combo End Sub الملف مرفق Masry_SALIM.xlsm

حرب هذا الكود يأخذ وقتاً بعض الشيء لان البيانات كثيرة حوالي 20 الف صف مع خلق صفحات جديدة اذا لم تكن موجودة مسبقاً Option Explicit Sub Get_More_sheets() Dim my_arr() Dim LrMM%, i%, x% Application.ScreenUpdating = False With Sheets("Sheet1") If .FilterMode Then .ShowAllData .Range("a1").AutoFilter End If End With Sheets("Sheet1").Range("a2", Range("a1").End(4)).Copy _ Sheets("Sheet1").Range("MM1") LrMM = Cells(Rows.Count, "MM").End(3).Row Sheets("Sheet1").Range("MM1:MM" & LrMM). _ RemoveDuplicates Columns:=1 LrMM = Cells(Rows.Count, "MM").End(3).Row ReDim my_arr(1 To LrMM) For i = 1 To LrMM my_arr(i) = Range("MM" & i) Next Sheets("Sheet1").Range("MM1:MM" & LrMM).Clear On Error Resume Next For i = 1 To LrMM x = Len(Sheets(my_arr(i)).Name) If x = 0 Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = my_arr(i) End If Next Sheets("sheet1").Activate On Error GoTo 0 For i = 1 To LrMM With Sheets("Sheet1").Range("a1").CurrentRegion .AutoFilter Field:=1, Criteria1:=my_arr(i) .SpecialCells(12).Copy _ Sheets(my_arr(i)).Range("A1") Sheets(my_arr(i)).Columns("A:B").AutoFit End With Next With Sheets("Sheet1") If .FilterMode Then .ShowAllData .Range("a1").AutoFilter End If End With MsgBox "That Is All" & Chr(10) & _ "Thank You ====> Salim" Application.ScreenUpdating = True End Sub الملف مرفق GET_sheets.xlsm

جرب هذا الحل COND_FPRMAT.xlsx

يمكن استعمال هذا الماكرو Option Explicit Sub copy_choosen_columns() Dim My_Max: My_Max = Range("a1").CurrentRegion.Rows.Count Dim I%, k% I = 2: k = 1 Sheets("sheet2").Cells.Clear With Sheets("sheet1") Do Until .Range("H" & I) = vbNullString Sheets("sheet2").Cells(1, k).Resize(My_Max).Value = _ .Cells(1, .Range("H" & I)).Resize(My_Max).Value I = I + 1: k = k + 1 Loop End With End Sub الملف مرفق copy_col.xlsm

بعد اذن الاخ وحيه هذا الماكرو Option Explicit Sub Get_Blanks() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With Dim Pr As Worksheet Dim Da As Worksheet Set Pr = Sheets("Print") Set Da = Sheets("Data") Dim LR_Pr%, k% Dim separator%: separator = 14 If IsError(Application.Match(Pr.Range("f2"), Da.Range("G:G"), 0)) Then MsgBox "Wrong name of Section" Pr.Range("A14:f5000").Clear GoTo Exit_Sub End If Dim x%: x = Application.CountIf(Da.Range("G:G"), Pr.Range("f2")) LR_Pr = Pr.Cells(Rows.Count, "b").End(3).Row If LR_Pr > 13 Then Pr.Range("a14").Resize(LR_Pr, 6).Clear End If For k = 1 To x - 1 Pr.Range("PRINCE_RG").Copy Pr.Range("a" & separator).PasteSpecial separator = separator + 14 Next Application.CutCopyMode = False fill_data Pr.Range("c4").Select Exit_Sub: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub Rem==================================== Sub fill_data() Dim col_Dt As New Collection Dim Pt As Worksheet: Set Pt = Sheets("Print") Dim Dt As Worksheet: Set Dt = Sheets("Data") Dim First_Row_dt%, Fix_Row_dt% Dim find_rng As Range Dim kk%: kk = 4 Dim Collec_num% Set find_rng = Dt.Range("g:g").Find(Pt.Range("f2")) If Not find_rng Is Nothing Then Fix_Row_dt = find_rng.Row: First_Row_dt = Fix_Row_dt col_Dt.Add Dt.Cells(Fix_Row_dt, 1).Value Do Set find_rng = Dt.Range("g:g").FindNext(find_rng) Fix_Row_dt = find_rng.Row If First_Row_dt = Fix_Row_dt Then Exit Do col_Dt.Add Dt.Cells(Fix_Row_dt, 1).Value Loop End If For Collec_num = 1 To col_Dt.Count Pt.Range("c" & kk) = col_Dt(Collec_num) kk = IIf(kk < 15, kk + 13, kk + 14) Next Set col_Dt = Nothing End Sub الملف مرفق Print_Shahadat.xlsm

زيادة في اثراء الموضوع هذا الكود Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address = "$A$2" And _ Target.Count = 1 Then My_validation End If Application.EnableEvents = True End Sub Rem================================ Sub My_validation() Dim Bayanat As Worksheet: Set Bayanat = Sheets("البيانات") Dim Amaliate As Worksheet: Set Amaliate = Sheets("العمليات") Dim arr(), Ro%, t%, Col%, st$ Ro = Bayanat.Range("a:a").Find(Amaliate.Cells(2, 1)).Row Col = Bayanat.Cells(Ro, Columns.Count).End(1).Column For t = 2 To Col ReDim Preserve arr(1 To t - 1) arr(t - 1) = Bayanat.Cells(Ro, t) Next st = Join(arr, ",") With Amaliate.Cells(2, 2).Validation .Delete .Add xlValidateList, Formula1:=st End With Amaliate.Cells(2, 2) = arr(1) Erase arr End Sub المبف مرفق variable_data_val.xlsm

ربما كان المطلوب Select_by_USForm.xlsm

ربما يكون المطلوب (العمود H ) من هذا الملف Tasalsul_new.xlsx

مشكور اخي بن علية على هذه الاضافة يمكن ايضاً تعديل المعادلة بواسطة OR دون زيادة شرط IF =IF(OR(COUNTIF($A$4:A4,A4)=SUMPRODUCT(($A$4:A4=A4)*($D$4:D4="تم التسديد")),D4="تم التسديد"),"",COUNTIF($A$4:A4,A4)-SUMPRODUCT(($A$4:A4=A4)*($D$4:D4="تم التسديد")))

جرب هذا الماكرو Sub delete_values() 'Created by Salim Hasbaya 24/5/2019 Dim i%, lr% lr = Cells(Rows.Count, "d").End(3).Row i = 3 Do Until i = lr + 1 If Application.CountIf(Range("d3:d" & i), _ Range("d" & i)) > 1 Then _ Range("d" & Range("d2:d" & lr). _ Find(Range("d" & i)).Row) = vbNullString i = i + 1 Loop End Sub الملف مرفق _New55.xlsm

جرب هذا الكود في كل من الملفين (يمكن ان يكون مفتاج الحل) و تكتشف الفرق Sub difference() Dim my_rg As Range Set my_rg = Range("a10").CurrentRegion my_rg.Select End Sub

قلت لك جرب هذا الكود في الملف المرفق لان الملف الذي رفعته لك غير الملف الذي ارسلته انت (جاول المقارنه بين الملفين واكتشف بنفسك المشكل) بغير هذه الطريقة لا يمكن التعلم