سليم حاصبيا

جرب المرفق كود جمع salim.rar

يجب تشغيل الماكرو من جديد كلما تم التعديل على البيانات يمكن وضع رز يقوم بتشفيل الماكرو

جرب هذا الماكرو Sub my_sum() Dim Lr As Integer, My_sheet As Worksheet Set My_sheet = Sheets("ورقة1") With My_sheet Lr = Application.Max(.Range("a:a")) + 4 .Range("b" & Lr + 2 & ":" & "e" & Lr + 2 & "").ClearContents .Cells(Lr + 2, 2) = "اجمالى الكشف" .Cells(Lr + 2, 3) = Application.Sum(Range("c4:c" & Lr)) .Cells(Lr + 2, 4) = Application.Sum(Range("d4:d" & Lr)) .Cells(Lr + 2, 5) = Application.Sum(Range("e4:e" & Lr)) End With End Sub

تم معالجة الامر 3454 salim.rar

اكتب في الخلية C7 هذه المعادلة =(QUOTIENT(B7,1)*60+MOD(B7,1)*100)/60 و في الخلية D7 هذه الاخرى =QUOTIENT(B7,1)*60+MOD(B7,1)*100

جرب الملف المرفق (يمكن زيادة عدد الصفحات و الاعمدة والتحكم بالبيانات مثل ما تريد) ALL_In_One Sheet.rar

جرب هذا الماكرو Sub Copy_To_Next_Row() Dim my_sh As Worksheet Dim LastRow As Integer Set my_sh = Sheets("test") If ActiveSheet.Name <> "test" Then Exit Sub LastRow = Cells(Rows.Count, 1).End(3).Row For i = 2 To LastRow +7 Step 3 If Not IsEmpty(Cells(i, 2)) Then Cells(i + 2, 2) = Cells(i + 1, 2) End If Next End Sub

الكود بعمل على اكثر من ذلك بكثير (مهما كان عدد الاسماء حنى و لو 2000000 اسم) انا ارسلت لك نموذج فقط و لا اعرف ما السبب عندك ربما كانت الاسماء مختلقة او التاريخ محتلف يين شيت و اخر

انظر الى المرفق كنموذج من 20 اسم sample salim.rar

استيدل الكود بهذا Sub copy_All_visible() Application.ScreenUpdating = False Dim My_sh As Worksheet Dim My_range As Range Dim k, m, lr, i, x As Integer Dim arrsh() As Integer k = Sheets.Count: m = 3: Set My_sh = Sheets(k): My_sh.Range("a3:m1000").ClearContents For i = 1 To k - 1 If Sheets(i).Visible = True Then t = t + 1: x = Sheets(i).Index ReDim Preserve arrsh(1 To t) arrsh(t) = Sheets(i).Index End If Next For y = 1 To UBound(arrsh) With Sheets(arrsh(y)) lr = .Cells(Rows.Count, 1).End(3).Row Set My_range = .Range("a6:k" & lr) End With With My_sh .Cells(m, 1) = Sheets(arrsh(y)).Cells(1, 2) .Cells(m, 2) = Sheets(arrsh(y)).Cells(2, 2) My_range.Copy .Range("c" & m).PasteSpecial xlPasteValues m = m + lr - 4 End With Next My_sh.Activate Range("a3").Select Erase arrsh Application.ScreenUpdating = True End Sub

جرب هذا الماكرو Sub Copy_Data() Application.ScreenUpdating = False Dim ws1, ws2, ws3 As Worksheet Set ws1 = Sheets("Main"): Set ws2 = Sheets("Actual Login logout") _ : Set ws3 = Sheets("Scheduled Data") Dim Foundcel2, Foundcel3 As Range Dim R2, R3 As Integer Dim Lr1, Lr2, Lr3 As Integer Dim Cel As Range Dim Count_data2, Count_data3 As Integer Dim My_Rg1, My_Rg2, My_Rg3 As Range Lr1 = ws1.Cells(Rows.Count, 1).End(3).Row: Set My_Rg1 = ws1.Range("b2:b" & Lr1) Lr2 = ws2.Cells(Rows.Count, 1).End(3).Row: Set My_Rg2 = ws2.Range("a2:a" & Lr2) Lr3 = ws3.Cells(Rows.Count, 1).End(3).Row: Set My_Rg3 = ws3.Range("a2:a" & Lr3) ws1.Select ActiveSheet.Range("c2:f" & Lr1).ClearContents For Each Cel In My_Rg1 Count2 = Application.CountIf(My_Rg2, Cel): Count3 = Application.CountIf(My_Rg3, Cel) If Count2 + Count3 <> 2 Then GoTo 1 Set Foundcel2 = My_Rg2.Find(what:=Cel): R2 = Foundcel2.Row Set Foundcel3 = My_Rg3.Find(what:=Cel): R3 = Foundcel3.Row Cel.Offset(0, 1) = ws2.Cells(R2, 4): Cel.Offset(0, 2) = ws2.Cells(R2, 5) Cel.Offset(0, 3) = ws3.Cells(R3, 4): Cel.Offset(0, 4) = ws3.Cells(R3, 5) 1: Next Application.ScreenUpdating = True End Sub

اليك المعادلة في المرفق وهي تعمل جيداً cherif 1.rar

جرب هذه المعادلة =INDEX({"ناجح";"ناجح بدين";"راسب"},MATCH(COUNTIF($N$14:$N$22,"ناجح"),{10;7;6},-1))

جرب هذا الماكرو Sub copy_All() Application.ScreenUpdating = False Dim My_sh As Worksheet Dim My_range As Range Dim k, m, lr, i As Integer k = Sheets.Count m = 3 Set My_sh = Sheets(k) My_sh.Range("a3:m1000").ClearContents For i = 2 To k - 1 With Sheets(i) lr = .Cells(Rows.Count, 1).End(3).Row Set My_range = .Range("a6:k" & lr) End With With My_sh .Cells(m, 1) = Sheets(i).Cells(1, 2) .Cells(m, 2) = Sheets(i).Cells(2, 2) My_range.Copy .Range("c" & m).PasteSpecial xlPasteValues m = m + lr - 4 End With Next My_sh.Activate Range("a3").Select Application.ScreenUpdating = True End Sub

بعد اذن اخي رجب و زيادة قي اثراء الموضوع هذه المعادلة:(ctrl + shift + enter) =INDEX($J$2:$J$9,MATCH($A$6&$B$6,$H$2:$H$9&$I$2:$I$9,0))

جرب الملف المرفق search_and_colorize.rar

جرب هذا الملف المعادلة حسب الصف حاول تحويلها حسب العامود كي تكتسب خبرة MAX_ADDRESS.rar

تم معالجة الموضوع انظر الى الصفحة Salim من المرفق Calender_by_choise 1.rar

ربما كان المطلوب Calender_by_choise.rar

جرب هذا الماكرو Sub formula_to_Vba() Dim Lr As Integer Lr = Sheets("سجل مبيعات نقد").Cells(Rows.Count, 2).End(3).Row Sheets("سجل مبيعات نقد").Range("j5:j" & Lr).ClearContents Sheets("سجل مبيعات نقد").Range("j5").Formula = "=IF(AND(B5>=$M$5,B5<=$M$6),'سجل مبيعات نقد'!C5,"""")" Range("j5").AutoFill Destination:=Range("j5:j" & Lr) Range("j5:j" & Lr).Value = Range("j5:j" & Lr).Value End Sub

ربما كان المطلوب sum_salim.rar

حاول اضاقة او تعديل اي شيء في عامودي الصف والفصل و ترى النتيجة

انظر الى المرفق يمكن استخراج التكرار حسب ما تريد (نص أو أرقام) لتعمل المعادلة بعد نسخها على العدد الكبير (5000 صف) يجب توسيع النطاق الى A5000 مع استعمال (Ctrl+Shift+enter)للمعادلة لانها معادلة صفيف الحل في الصفحة Salim من المرفق TEKRAR COUNT 1.rar

جرب هذا الملف Book1Salim.rar

اكتب فاصلة عليا " ' " قبل الرقم الفاصلة العليا هي حرف الطاء باللغة العربية(يجب ان تكون لغة الكيبورد اجنبية)