سليم حاصبيا

جرب هذا الماكرو الارقام الملونة هي الارقام الخاصة salim الجمع.rar

انا لم افهم لغاية الان ما هي الارقام الخاصة و ما تريد ان تجمع بالضبط

تحميل الملف Time.rar

جرب هذا الملف working with order.rar

ربما هذا الكود يقوم بالمهمة Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Column = 1 And Target.Count = 1 And Target.Address <> "$A$1" Then If Target.Offset(, 3) = "" Then Target.Offset(, 3) = Time End If Application.EnableEvents = True End Sub

جرب هذا الكود يجب تغيير اسم الصفحة الى "jan" ,وذلك لحسن التعامل مع اللغة الاجنبية (و لا اعلم لماذا حملت الملف كله كان يكفي حوالي 100 صف -كنموذج) Sub find_for_me() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With If ActiveSheet.Name <> "jan" Then GoTo 1 Set my_sh = Sheets("jan") Dim FoundCell As Range Dim LastCell As Range Dim FirstAddr, My_string As String My_string = "المبيعات" my_sh.Range("H2:H50000").Clear Set FoundCell = my_sh.Range("d:d").Find(what:=My_string, after:=my_sh.Cells(1, 4), lookat:=xlPart) If Not FoundCell Is Nothing Then FirstAddr = FoundCell.Address t = 1 Do Until FoundCell Is Nothing Cells(m + 2, 8) = FoundCell.Row - 1 Cells(FoundCell.Row - 1, 4) = t m = m + 1 t = t + 1 Set FoundCell = Range("D:D").FindNext(after:=FoundCell) If FoundCell.Address = FirstAddr Then Exit Do Loop '============================== k = 2 Do Until Cells(k, "h") Is Nothing ActiveSheet.Hyperlinks.Add Anchor:=Cells(k, "h"), Address:="", SubAddress:= _ "jan!E" & Cells(k, "h").Value, ScreenTip:="GOTO E" & Cells(k, "h").Value k = k + 1 Loop '===================== 1: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub مرفق الملف مع الكود Hyper_Salim.rar

انسخ هذه المعادلة الى الخلية J5 اضفط Enter ثم اسحبها يساراً ثم نزولاُ =IF(D5="غ","غائب",IF(D5=0,"",VLOOKUP(D5/D$4,{0,"دون المستوى";0.5,"مقبول";0.65,"جيد";0.75,"جيد جداً";0.85,"ممتاز"},2)))

استبدل الكود بهذا Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Column = 4 Then _ ActiveWindow.Zoom = 120 Else _ ActiveWindow.Zoom = 80 End Sub

الماكرو يقوم بنقل البيانات تم يرتبها حسب المطلوب التعديل في الورقة الاولى و ينقل مباشرة الى باقي الاوراق يمجرد الضغط على الزر Transfere Data with sort.rar

جرب هذا الكود مبدئياً التعديل في الورقة الاولى و ينقل مباشرة الى باقي الاوراق يمجرد الضفط على الزر تم تصحيح الخطأ Transfere Data.rar

جرب هذا الملف تختار المجلد المناسب و ترى محتوياته و عندما تضغط على اي ملف من المحتويات يفتح الملف المذكور listfiles.rar

جرب هذا الملف اكتب الصفوف من الى في الخلايا B&A Hide_rows.rar

تمت معالجة الامر بناء على امرين 1-عدد الايام الفعلية بغض النظر عن تاريخ البداية والنهاية 2-عدد الايام الفعلية مع الاخذ بالحسبان تاريخ البداية والنهاية لا اعلم ايهما مناسب لك بالنسبة لعدد الزيارات لم افهم المطلوب 1تجربة salim.rar

بكا تأكيد يمكنك فعل ذلك

الملف مع المعادلة salimالتاريخ الافتراضي.rar

تلزم هذه المعادلة =IF(A1="","",A1)

جرب هذه المعادلات دالة الوقت - طرح و جمعsalim.rar

امسح محتويات العامود S كاملة اضف هذا السطر الى الكود مباشرة بعد عبارة :Exitsub على سطر مستقل ثم تفذ الماكرو S_sh.Range("s:s").Clear

تم معالجة الامر مع المجاميع و زيادة حبتين قائمة حساب salim with summution.rar الماكرو المطلوب Option Explicit Sub filter_me() Dim S_sh, T_sh As Worksheet Dim My_rg As Range Dim T2, T3, T4 As String Dim VaL2, VaL3, VaL4, x, y, Z As Double Dim Lrs, Lrss, LrSalim As Long Dim m, k, i As Integer If ActiveSheet.Name <> "Salim" Then GoTo ExitSub Application.ScreenUpdating = False Application.Calculation = xlCalculationManual On Error GoTo ExitSub Set S_sh = Sheets("Data"): Set T_sh = Sheets("Salim") Lrs = S_sh.Cells(Rows.Count, "e").End(3).Row T_sh.Range("a1:H150000").Clear Range("e2:e" & Lrs).Copy Range("S1") Range("s1:s" & Lrs).RemoveDuplicates Columns:=1, Header:=xlNo Lrss = S_sh.Cells(Rows.Count, "s").End(3).Row m = 1 For i = 1 To Lrss T_sh.Range("j2").Formula = "=Data!E2=Data!$S$" & i Sheets("Data").Range("A1:H" & Lrs).AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Range("J1:J2"), CopyToRange:=Range("A" & m), Unique:=False m = m + Application.CountIf(S_sh.Range("e2:e" & Lrs), S_sh.Range("s" & i)) + 2 Next LrSalim = T_sh.Cells(Rows.Count, "g").End(3).Row Set My_rg = T_sh.Range("g2:g" & LrSalim).SpecialCells(2, 1) For k = 1 To My_rg.Areas.Count My_rg.Areas(k).Select '====================================== On Error Resume Next With My_rg.Areas(k) x = .Cells(1).Row y = .Rows.Count Z = x + y T2 = "SUMIFS($G$" & x & ":$G$" & Z - 1 & ",$H$" & x & ":$H$" & Z - 1 & "," & "$M$2" & ")*VLOOKUP($M$2,$M$2:$N$4,2,0)" T3 = "SUMIFS($G$" & x & ":$G$" & Z - 1 & ",$H$" & x & ":$H$" & Z - 1 & "," & "$M$3" & ")*VLOOKUP($M$3,$M$2:$N$4,2,0)" T4 = "SUMIFS($G$" & x & ":$G$" & Z - 1 & ",$H$" & x & ":$H$" & Z - 1 & "," & "$M$4" & ")*VLOOKUP($M$4,$M$2:$N$4,2,0)" If Not (IsEmpty(Evaluate(T2))) Then VaL2 = Evaluate(T2) Else VaL2 = 0 If Not (IsEmpty(Evaluate(T3))) Then VaL3 = Evaluate(T3) Else VaL3 = 0 If Not (IsEmpty(Evaluate(T4))) Then VaL4 = Evaluate(T4) Else VaL4 = 0 Cells(Z, "g") = VaL2 + VaL3 + VaL4 Cells(Z, "H") = "Sum:" End With Next Cells(LrSalim + 1, "d") = "Total Sum:": Cells(LrSalim + 1, "d").Interior.ColorIndex = 35 Cells(LrSalim + 1, "c").Formula = "=SUMPRODUCT(--($E$2:$E$100000=""""),$G$2:$G$100000)" Cells(LrSalim + 1, "c").Interior.ColorIndex = 35 ExitSub: Range("a1").Select Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub

استعمل مؤقتاً الماكرو الموجود في المشاركة الاولى (مع تعديل عدد الصفوف من 500 الى 150000) قائمة حساب salim.rar ريثما نجد حلاً للمجاميع

لازالة الحماية عن الورقة اضغط على الزر Alt باستمرار ثم الثلاثة ازار بالتتابع R ثم P ثم S ثم OK نفس العملية لاعادة الحماية ملاحظة مهمة:لغة لوحة المفاتيح يجب ان تكون اجنبية

تم التعدبل على الملف للحصول على المجاميع قائمة حساب salim with sum.rar الكود مرفق Sub filter_me() Dim S_sh, T_sh As Worksheet Dim X, Y, Z As Long Dim LRSS, LRS, M As Integer Dim T1, T2, T3 As String Set S_sh = Sheets("Data"): Set T_sh = Sheets("Salim") LRS = S_sh.Cells(Rows.Count, "e").End(3).Row T_sh.Range("a1:H500").Clear Range("e2:e" & LRS).Copy Range("S1") Range("s1:s" & LRS).RemoveDuplicates Columns:=1, Header:=xlNo LRSS = S_sh.Cells(Rows.Count, "s").End(3).Row M = 1 For i = 1 To LRSS T_sh.Range("j2").Formula = "=Data!E2=Data!$S$" & i Sheets("Data").Range("A1:H" & LRS).AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Range("J1:J2"), CopyToRange:=Range("A" & M), Unique:=False On Error Resume Next M = M + Application.CountIf(S_sh.Range("e2:e" & LRS), S_sh.Range("s" & i)) + 2 T1 = "=G" & M - 4 & "*VLOOKUP(H" & M - 4 & ",$M$2:$N$4,2,0)" If IsNumeric(Evaluate(T1)) Then X = Evaluate(T1) Else X = 0 T2 = "=G" & M - 3 & "*VLOOKUP(H" & M - 3 & ",$M$2:$N$4,2,0)" If IsNumeric(Evaluate(T2)) Then Y = Evaluate(T2) Else Y = 0 T3 = "=G" & M - 2 & "*VLOOKUP(H" & M - 2 & ",$M$2:$N$4,2,0)" If IsNumeric(Evaluate(T3)) Then Z = Evaluate(T3) Else Z = 0 Cells(M - 1, 8) = "The sum:" Cells(M - 1, 7) = X + Y + Z Next S_sh.Range("s:s").Clear End Sub

تم معالجة القسم الاكبر من المطلوب بقيت عملية الحسابات (فيما بعد لضيق الوقت) نم تغيير اسم الصغحات لحسن العمل مع اللغة الاجنبية قائمة حساب salim.rar

تم النعديل يمكن اختيار ما تشاء من القوائم المنسدلة في العامود H & I و تضفط على الزر Run للعودة الى البيانات اضفط على Show_All Show_hide rows 1.rar

جرب هذا المثال Show_hide rows.rar