سليم حاصبيا

TRY THIS MACRO FOR THE FORMATING Option Explicit Sub Get_najeh() Application.ScreenUpdating = False Dim s As Worksheet, T As Worksheet Dim F_Rg As Range Dim Ro%, Str$, My_ro, k, m, mmax% Dim Arr: Arr = Array(2, 3, 26, 35, 44, 53, 65, 82) Set s = Sheets("الشيت"): Set T = Sheets("كشف ناجح") T.Range("b8:N100").Clear Ro = s.Cells(Rows.Count, "Di").End(3).Row Set F_Rg = s.Range("Di12:Di" & Ro) Str = "ناجح" F_Rg.AutoFilter 1, Str My_ro = s.Cells(Rows.Count, "Di").End(3).Row m = 3 For k = LBound(Arr) To UBound(Arr) s.Cells(13, Arr(k)).Resize(My_ro - 8).SpecialCells(12).Copy T.Cells(8, m).PasteSpecial (xlPasteValues) m = m + 1 Next If s.FilterMode Then s.ShowAllData F_Rg.AutoFilter End If mmax = T.Cells(Rows.Count, 3).End(3).Row With T.Cells(8, 2).Resize(mmax - 7, 13) .Borders.LineStyle = 1 .Font.Size = 18 .Font.Bold = True .InsertIndent 1 .Columns(1).Formula = "=MAX($B$7:B7)+1" .Value = .Value End With T.Cells(8, 2).Select Application.ScreenUpdating = True End Sub File Included My_filter_new.xlsm

الجداول في اكسل يجب ان تكون مستقلة عن اي تدخل خاجي من البيانات(دون دمج خلايا) كي يعمل اي ماكرو كما هو مبرمج لذلك تم ادراج صف فارغ فوق الجدول في الشيت الاول والشيت الثاني (بقي عامودين في الداتا / تربية دينيه و الحالة / لم أعرف موقعهما لذلك قم بزيادة ارقام الاعمدة التي تناسبها على الــ Array محافظاً على الترتيب) الكود Option Explicit Sub Get_najeh() Dim s As Worksheet, T As Worksheet Dim F_Rg As Range Dim Ro%, Str$, My_ro, k, m Dim Arr: Arr = Array(2, 3, 26, 35, 44, 53, 65, 82) Set s = Sheets("الشيت"): Set T = Sheets("كشف ناجح") T.Range("c8:N100").ClearContents Ro = s.Cells(Rows.Count, "Di").End(3).Row Set F_Rg = s.Range("Di12:Di" & Ro) Str = "ناجح" F_Rg.AutoFilter 1, Str My_ro = s.Cells(Rows.Count, "Di").End(3).Row m = 3 For k = LBound(Arr) To UBound(Arr) s.Cells(13, Arr(k)).Resize(My_ro).Copy _ T.Cells(8, m) m = m + 1 Next If s.FilterMode Then s.ShowAllData F_Rg.AutoFilter End If End Sub الملف مرفق My_filter.xlsm

لا أعلم اذا كان هذا المطلوب (معادلات) MY_tekrar.xlsx أو هذا الملف ماكرو MY_tekrar.xlsm

جرب هذا الماكرو (النتيجة في شيت "Salim" Option Explicit Sub Every_two() Dim my_max%, i%, k% my_max = Sheets("Main").Cells(Rows.Count, 3).End(3).Row Sheets("Salim").Cells(1, 1).CurrentRegion.ClearContents k = 1 For i = 1 To my_max Step 2 With Sheets("Main").Cells(i, 3) Sheets("Salim").Cells(k, 1) = _ .Value & " " & .Offset(1) k = k + 1 End With Next End Sub الملف مرفق two_in_One.xlsm

هذا الكود لا يدرج لك المكرر Sub Tarhil() Dim i!, Ro! Dim A As Worksheet, E As Worksheet Dim RgA As Range Dim DIC_C As Object, dIC_j As Object Application.ScreenUpdating = False Set E = Worksheets("EZN") Set A = Worksheets("ALL") Set RgA = A.Range("A1").CurrentRegion.Offset(1) RgA.Clear Ro = E.Cells(Rows.Count, 3).End(3).Row If Ro < 5 Then GoTo End_Me Set DIC_C = CreateObject("Scripting.Dictionary") Set dIC_j = CreateObject("Scripting.Dictionary") For i = 5 To Ro If E.Cells(i, 3) <> vbNullString Then DIC_C(E.Cells(i, 3)) = E.Cells(i, 6) End If If E.Cells(i, 13) <> vbNullString Then dIC_j(E.Cells(i, 13)) = E.Cells(i, 10) End If Next With A.Cells(2, 1).Resize(DIC_C.Count) .Value = Application.Transpose(DIC_C.Items) .Offset(, 1) = Application.Transpose(DIC_C.keys) .Offset(, 2) = Application.Transpose(dIC_j.Items) .Offset(, 3) = Application.Transpose(dIC_j.keys) End With Ro = A.Range("a1").CurrentRegion.Rows.Count With A.Range("a1").CurrentRegion.Offset(1).Resize(Ro - 1) .Borders.LineStyle = 1 .Interior.ColorIndex = 35 .Font.Size = 14 .Font.Bold = True .InsertIndent 1 End With End_Me: Set DIC_C = Nothing: Set dIC_j = Nothing Set A = Nothing: Set E = Nothing Set RgA = Nothing Application.ScreenUpdating = True End Sub الملف مرفق Tel_Test.xlsm

جرب هذا الماكرو Sub Update_Values() Dim S As Worksheet Dim T As Worksheet Dim S_rg As Range, T_rg As Range Dim F_rg As Range, Ro%, I%, SS, My_Sum# Set S = Sheets("Source_Sh") Set T = Sheets("Target_Sh") Set S_rg = S.Range("B2", S.Range("B1").End(4)) Set T_rg = T.Range("B2", T.Range("B1").End(4)) For I = 1 To S_rg.Cells.Count Set F_rg = T_rg.Find(S_rg.Cells(I), lookat:=xlWhole) If Not F_rg Is Nothing Then Ro = F_rg.Row SS = IIf(IsNumeric(S_rg.Cells(I).Offset(, 3)), S_rg.Cells(I).Offset(, 3), 0) My_Sum = IIf(IsNumeric(T.Cells(Ro, 3)), T.Cells(Ro, 3), 0) T.Cells(Ro, 3) = SS + My_Sum S_rg.Cells(I).Offset(, 3) = 0 End If Next End Sub الملف مرفق Summation.xlsm

تم التعديل على الماكرو ليعمل كما تريد Option Explicit Sub get_value() Rem Created by salim Hasbaya On 10/3/2020 Dim dic As Object, i%, ky, t, cel As Range Dim rg As Range, m%, My_val If ActiveSheet.Name <> "Salim" Then GoTo Exit_Me Application.ScreenUpdating = False Set dic = CreateObject("Scripting.Dictionary") Range("F7").CurrentRegion.Clear Range("C7:C1000").Interior.ColorIndex = xlNone m = 6 For i = 7 To 937 Step 90 dic(i) = vbNullString Next For Each ky In dic.keys Set rg = Cells(ky, 3).Resize(90) Set rg = rg.SpecialCells(2) For Each cel In rg t = cel.Address(0, 0) My_val = cel.Value Next Cells(6, m) = t Cells(7, m) = My_val Range(t).Interior.ColorIndex = 6 m = m + 1 Next With Range("F7").CurrentRegion .Interior.ColorIndex = 6 .Borders.LineStyle = 1 .Font.Bold = True .Font.Size = 14 .HorizontalAlignment = 2 .InsertIndent 1 End With Exit_Me: Application.ScreenUpdating = True Set dic = Nothing: Set cel = Nothing Set rg = Nothing End Sub الملف مرفق My_Last_Cells.xlsm

اذن كيف تميز اين يبدأ اي نطاق و اين ينتهي و هل صفوف كل نطاق ثابتة ام متغيرة؟؟

See This video https://www.youtube.com/watch?v=TcnA9j_J4xg

الحل E4-1.xlsx

كي يعمل الكود الذي وضعته لك في المشاركة الثانية يجب وضع نفس الالوان كما في الملف الذي رفعنه لك في المشاركة الثانية (Last_Cell_ALL) أو تغيير الـــ Array الى نفس الالوان التي عندك في الملف

اذا كنت تريد احتساب النطاقات الفارغة هذا الماكرو ينفع في ذلك ايضاً Option Explicit Sub get_col_1() Dim arr(), My_val, K%, Rg As Range Dim Ro%, m%, i% Ro = Cells(Rows.Count, 3).End(3).Row arr = Array(6, 44, 37, 40) Range("F7").Resize(, Ro).Clear m = 6 For i = LBound(arr) To UBound(arr) My_val = vbNullString For K = 7 To Ro If Cells(K, 3).Interior.ColorIndex = arr(i) _ And Cells(K, 3) <> vbNullString Then My_val = Cells(K, 3) End If Next K With Cells(7, m) .Value = My_val .Interior.ColorIndex = arr(i) End With m = m + 1 Next i End Sub الملف مرفق Last_Cell_ALL.xlsm

Try This File Last_Cell.xlsm

Try This File Show_Hide.xlsm

يجب ان يكون العامود الثاني(B) فارغاً وايضاً الصف الثالث(ٌRow 3) كي يعرف الاكسل اي مجموعة يجب اخذها كي يمسح القديم منها ويسجل الجديد الملف من جديد Distribution_new.xlsm

يمكن ذلك باستبدال m=m+1 الى m=m+2 داخل الماكرو

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

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

جرب هذا الملف الماكرو Option Explicit Sub Touzi3() Dim RGA As Range Dim n%, m%, Ro%, i%, x x = Range("E1") If Not IsNumeric(x) Or x < 1 Then x = 10: Range("E1") = x Else x = Range("E1") End If m = 3 Range("C4").CurrentRegion.ClearContents Set RGA = Range("A4").CurrentRegion Ro = RGA.Rows.Count + 3 n = Ro \ x For i = 4 To Ro Step x Cells(4, m).Resize(x).Value = _ Cells(i, 1).Resize(x).Value m = m + 1 Next End Sub Distribution.xlsm

بعد اذن الاخ ابو عيد هذا الملف Spec_Suite.xlsx

Try this file Offecna.xlsx

ما عليك الا اضافة 1 (او اي رقم تريده) الى المعادلة كي تصبح هكذا =IF(OR(A2="",B2=""),"",DATEDIF(DATE(B2,1,1),TODAY(),"y")+1)

شاهد هذا الفيديو https://www.youtube.com/watch?v=0YNhxVu2a5s

اذا كان هذا الجواب شافياً اضغط على افضل اجابة لاغلاق الموضوع

ربما كان هذا المطلوب Repeet_by_choise.xlsx