سليم حاصبيا

لا أحد يستطيع التعامل مع صورة ارفق الملف لتحصل على مساعدة احد الاساتذة

هو أنت اللي ( عامل تنسيق ليومي الجمعة و السبت كعطلة نهاية الاسبوع) لماذا لا تذكر من وضع لك المعادلات في الملف الذي رفعته؟؟ ( كحفظ حقوق النشر لا أكثر والقليل من العرفان بالجميل) جرب هذا الكود (تستطبع التنقل ضمن الجدول بواسطة المفتاح Tab والبرنامج يقفز الخلايا الخضراء) Option Explicit Private Sub Worksheet_Activate() Application.ScreenUpdating = False Block_cells Application.ScreenUpdating = True End Sub '========================================= Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False Application.ScreenUpdating = False If Target.Address = "$M$1" Or Target.Address = "$V$1" _ Or Target.Address = "$Z$1" Then Block_cells End If Application.EnableEvents = True Application.ScreenUpdating = True End Sub '======================================= Sub Block_cells() With Sheets("Sheet1") .Unprotect .Cells.Locked = True .Range("B1:AF33").Locked = False End With On Error Resume Next Dim k% For k = 2 To 32 If Weekday(Cells(3, k)) > 5 Or Not IsDate(Cells(3, k)) Then Range(Cells(4, k), Cells(33, k)).Locked = True End If Next On Error GoTo 0 Sheets("Sheet1").Protect , EnableSelection = xlUnlockedCells End Sub الملف مرفق Protect_Abscent.xlsm

لم أفهم ما تقصد بكلمة تجميد

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

اضغط فقط على الزر الاحمر في الورقة

بعد اذن أخي بن علية هذا الماكرو يقوم بالعمل Option Explicit Sub salim_sum() If ActiveSheet.Name <> "ورقة1" Then Exit Sub Dim lar%: lar = Cells(Rows.Count, 1).End(3).Row Dim i%, k%: k = 2 Dim arr() ReDim Preserve arr(1 To 1): arr(1) = 2 For i = 1 To lar + 1 If Cells(i, 1) = vbNullString Then ReDim Preserve arr(1 To k): arr(k) = Cells(i, 1).Row k = k + 1 Dim x, y End If Next For i = LBound(arr) To UBound(arr) - 1 If i = 1 Then x = arr(i + 1) - 1: y = arr(i) Else x = arr(i + 1) - 1: y = arr(i) + 1 End If Cells(arr(i + 1), 3).Formula = "=SUM(C" & y & ":C" & x & ")" Cells(arr(i + 1), 3).AutoFill Cells(arr(i + 1), 3).Resize(1, 10) Cells(arr(i + 1), 3).Resize(1, 10).Value = _ Cells(arr(i + 1), 3).Resize(1, 10).Value Next End Sub الملف مرفق salim_summation .xlsm

ممكن هذا الملف بواسطة المعادلات أو الماكرو Tekrar_by_choise.xlsm

هذه المعادلة اسحبها يميناً 3 أعمدة ونزولا قدر ما تريد =IF(C3="","",SUM(C3,1)) أو =IF(C3="";"";SUM(C3;1)) المعادلة تأخذ بعين الاعتبار (النص تعتبره صفراً)

المعادلة الصّحيحة =IF(COUNTBLANK(F9:H9)=0,ROUND(SUM(F9:H9)/3,2),"") او =IF(COUNTBLANK(F9:H9)=0;ROUND(SUM(F9:H9)/3;2);"")

زيادة في تقديم الأفضل هذا الكود Option Explicit Sub Give_ma7soul_new() Application.ScreenUpdating = False Dim sh1 As Worksheet: Set sh1 = Sheets("تجهيز (2)") Dim sh2 As Worksheet: Set sh2 = Sheets("ورقة2") Dim lr1: lr1 = sh1.Cells(Rows.Count, 2).End(3).Row Dim lr2: lr2 = sh2.Cells(Rows.Count, 2).End(3).Row If lr2 < 7 Then lr2 = 7 Dim My_rg As Range, i% Dim x%, y%, z% Dim k%: k = 3 Dim st$: st = sh2.Range("c3") Dim m%: m = 7: Dim col%: col = 3 Dim Matc% Dim s1#, s2#, s3 Dim My_col% Dim part_sum1#, part_sum2#, part_sum3# Dim Newlr% Dim row_last_sum% '================== Dim ar() Dim xx%: xx = 1 For i = 30 To 600 Step 30 ReDim Preserve ar(1 To xx): ar(xx) = i xx = xx + 1 Next '================== sh2.Range("b7:F" & lr2 + 2).ClearContents On Error Resume Next My_col = sh1.Rows(7).Find(st).Column On Error GoTo 0 If My_col = 0 Then GoTo 1 Set My_rg = sh1.Cells(9, My_col).Resize(lr1, 3) For i = 9 To lr1 x = (My_rg.Cells(i - 8, 1) <> 0) y = (My_rg.Cells(i - 8, 2) <> 0) z = (My_rg.Cells(i - 8, 3) <> 0) If x + y + z = 0 Then GoTo next_i sh2.Cells(m, k) = sh1.Cells(i, 2) sh2.Cells(m, col + 1).Resize(, 3).Value = _ My_rg.Cells(i - 8, 1).Resize(, 3).Value s1 = s1 + sh2.Cells(m, col + 1) s2 = s2 + sh2.Cells(m, col + 2) s3 = s3 + sh2.Cells(m, col + 3) sh2.Cells(m, col - 1) = sh1.Cells(i, 1) m = m + 1 On Error Resume Next Matc = Application.Index(ar, Application.Match(m, ar, 0)) If Matc <> 0 Then m = Matc + 2 Matc = 0 With sh2.Cells(m - 2, col) .Value = "Sum Of This Page" .Offset(1, 0) = " Sum Of Previous" .Offset(0, 1) = s1 .Offset(0, 2) = s2 .Offset(0, 3) = s3 part_sum1 = part_sum1 + s1: s1 = 0 part_sum2 = part_sum2 + s2: s2 = 0 part_sum3 = part_sum3 + s3: s3 = 0 .Offset(1, 1) = part_sum1 .Offset(1, 2) = part_sum2 .Offset(1, 3) = part_sum3 End With End If On Error GoTo 0 next_i: Next '====================================== Newlr = sh2.Cells(Rows.Count, 3).End(3).Row + 1 row_last_sum = sh2.Range("C:C").Find(what:="Sum Of Previous", _ after:=sh2.Range("c1"), searchdirection:=xlPrevious).Row sh2.Cells(Newlr, 3) = "Sum Of This Page" sh2.Cells(Newlr + 1, 3) = "Total Sum" sh2.Cells(Newlr, 4).Formula = _ "=SUM(D" & row_last_sum + 1 & ":D" & Newlr - 1 & ")" sh2.Cells(Newlr, 5).Formula = _ "=SUM(E" & row_last_sum + 1 & ":E" & Newlr - 1 & ")" sh2.Cells(Newlr, 6).Formula = _ "=SUM(F" & row_last_sum + 1 & ":F" & Newlr - 1 & ")" sh2.Cells(Newlr + 1, 4) = Cells(row_last_sum, 4) + Cells(Newlr, 4) sh2.Cells(Newlr + 1, 5) = Cells(row_last_sum, 5) + Cells(Newlr, 5) sh2.Cells(Newlr + 1, 6) = Cells(row_last_sum, 6) + Cells(Newlr, 6) sh2.Cells(Newlr, 4).Resize(2, 3).Value = _ sh2.Cells(Newlr, 4).Resize(2, 3).Value '----------------------------- ActiveSheet.ResetAllPageBreaks Newlr = sh2.Cells(Rows.Count, 3).End(3).Row sh2.PageSetup.PrintArea = sh2.Range("b1:f" & Newlr).Address For i = 30 To Newlr Step 30 ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Cells(i + 2, 1) Next 1: Erase ar Application.ScreenUpdating = True End Sub الملف مرفق Salim_up_Advanced.xlsm

تم معالجة الأمر الكود Option Explicit Sub Give_ma7soul_new() Application.ScreenUpdating = False Dim sh1 As Worksheet: Set sh1 = Sheets("تجهيز (2)") Dim sh2 As Worksheet: Set sh2 = Sheets("ورقة2") Dim lr1: lr1 = sh1.Cells(Rows.Count, 2).End(3).Row Dim lr2: lr2 = sh2.Cells(Rows.Count, 2).End(3).Row If lr2 < 7 Then lr2 = 7 Dim My_rg As Range, i% Dim x%, y%, z% Dim t%: t = 1 Dim k%: k = 3 Dim st$: st = sh2.Range("c3") Dim m%: m = 7: Dim col%: col = 3 Dim Matc% Dim s1#, s2#, s3 '================== Dim ar() Dim xx%: xx = 1 For i = 30 To 600 Step 30 ReDim Preserve ar(1 To xx): ar(xx) = i xx = xx + 1 Next '================== sh2.Range("b7:F" & lr2).ClearContents Select Case st Case "محصول 1": Set My_rg = sh1.Range("c9:E" & lr1) Case "محصول 2": Set My_rg = sh1.Range("H9:J" & lr1) Case "محصول 3": Set My_rg = sh1.Range("M9:O" & lr1) Case "محصول 4": Set My_rg = sh1.Range("R9:T" & lr1) Case "محصول 5": Set My_rg = sh1.Range("W9:Y" & lr1) Case "محصول 6": Set My_rg = sh1.Range("AB9:AD" & lr1) Case Else: GoTo 1 End Select For i = 9 To lr1 x = (My_rg.Cells(i - 8, 1) <> 0) y = (My_rg.Cells(i - 8, 2) <> 0) z = (My_rg.Cells(i - 8, 3) <> 0) If x + y + z = 0 Then GoTo next_i sh2.Cells(m, k) = sh1.Cells(i, 2) sh2.Cells(m, col + 1).Resize(, 3).Value = _ My_rg.Cells(i - 8, 1).Resize(, 3).Value s1 = s1 + sh2.Cells(m, col + 1) s2 = s2 + sh2.Cells(m, col + 2) s3 = s3 + sh2.Cells(m, col + 3) sh2.Cells(m, col - 1) = sh1.Cells(i, 1) m = m + 1 On Error Resume Next Matc = Application.Index(ar, Application.Match(m, ar, 0)) If Matc <> 0 Then m = Matc + 2 Matc = 0 sh2.Cells(m - 2, col) = "Sum" sh2.Cells(m - 2, col + 1) = s1: s1 = 0 sh2.Cells(m - 2, col + 2) = s2: s2 = 0 sh2.Cells(m - 2, col + 3) = s3: s3 = 0 End If On Error GoTo 0 next_i: Next ActiveSheet.ResetAllPageBreaks Dim Newlr%: Newlr = sh2.Cells(Rows.Count, 3).End(3).Row sh2.PageSetup.PrintArea = sh2.Range("b1:f" & Newlr).Address For i = 30 To Newlr Step 30 ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Cells(i + 1, 1) Next 1: Application.ScreenUpdating = True End Sub الملف مرفق Salim_up1.xlsm

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

ليس هناك معادلة بل تم الحل بواسطة البرمجة VBA

جرب هذا الملف example_سليم.xlsm

جرب هذا الماكرو Option Explicit Sub Give_Uniques() Application.ScreenUpdating = False Dim d As Object, i As Long Dim Mysh As Worksheet: Set Mysh = Sheets("قائمة جرد المكتبة ") Dim lr As Long: lr = Mysh.Cells(Rows.Count, "C").End(3).Row Dim mysh2 As Worksheet: Set mysh2 = Sheets("المطلوب") Set d = CreateObject("system.collections.arraylist") For i = 4 To lr If Mysh.Cells(i, 3).Value <> vbNullString And _ Not d.contains(Mysh.Cells(i, 3).Value) Then _ d.Add Mysh.Cells(i, 3).Value Next With mysh2 .Range("a2", Range("A1").End(4)).ClearContents .OLEObjects("Combobox1").Object.List = _ Application.Transpose(d.toarray) .Range("a2").Resize(d.Count - 1) = _ Application.Transpose(d.toarray) End With d.Clear Application.ScreenUpdating = True End Sub الملف Claseur_salim.xlsm

ارفغ ملفاً (20 صف 10 أعمدة تقريباً ) مع شرح لما تريد لمعالجة الأمر

أخي في اكسل هناك ملايين الالوان كبف لك ان تعرف رقم كل لون ؟

جرب هذا الملف من جديد Sum_Average.xlsm

خل آحر 55_55.xlsx

جرب هذا الماكرو Option Explicit Sub Calc_Moyen() Dim col%, rw%, m%, k% Dim Total_sum# Dim sBlank#, tBlank% Dim sYellow#, tYellow% rw = Range("B4", Range("b3").End(4)).Rows.Count + 3 col = Range("A4", Range("B4").End(2)).Columns.Count For m = 4 To rw For k = 2 To col - 4 Total_sum = Total_sum + Cells(m, k) If Cells(m, k).Interior.ColorIndex <> 6 Then sBlank = sBlank + Cells(m, k) tBlank = tBlank + 1 Else sYellow = sYellow + Cells(m, k) tYellow = tYellow + 1 End If Next With Cells(m, col) .Offset(, -3) = Total_sum .Offset(, -2) = Total_sum / (tYellow + tBlank) .Offset(, -1) = sBlank .Value = IIf(tYellow <> 0, sBlank / tBlank, 0) End With sBlank = 0: tBlank = 0 sYellow = 0: tYellow = 0 Next Cells(4, col).Select End Sub الملف مرفق sum_Aver.xlsm

فتش جيداً في التواريخ اللي انت واضعها ترى ان التواريخ التي استخرجها الماكرو غير موجودة في الجدول

جرب هذا الماكرو Option Explicit Sub Find_Missing() With Sheets("ورقة2") Dim x Dim y Dim cell As Range Dim arr() Dim k%: k = 1 Dim Myrange As Range: Set Myrange = .Range("a1", Range("a1").End(4)) Dim my_Min: my_Min = Application.Min(Myrange) Dim my_max: my_max = Application.Max(Myrange) x = my_Min .Range("d2", Range("d1").End(4)).ClearContents For Each cell In Myrange If Month(x) <> Month(Myrange.Cells(1)) Then GoTo 1: y = Not (IsError(Application.Match(x, Myrange, 0))) If Not y Then ReDim Preserve arr(1 To k): arr(k) = Format(x, "d") k = k + 1 End If x = x + 1 1: Next Range("d2").Resize(UBound(arr) - LBound(arr) + 1, 1) = Application.Transpose(arr) End With End Sub الملف مرفق SALIM_TAB.xlsm

تم معالجة الامر Book_SAALIM.xlsx

Try this file salim_tab.xls

جرب هذه المعادلة في الحلية H17 واسحب نزولاً =IF(F17="","",TEXT(F17,"[$-10A0000]DDD/D MMM/YYY"))