سليم حاصبيا

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

جرب هذا الكود (في جدث الصفحة) Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Static t% Application.EnableEvents = False If Target.Address = "$A$1" And Target.Value <> vbNullString Then Target.Offset(, 3) = t + 1 t = t + 1 End If Application.EnableEvents = True End Sub الملف مرفق STATIC_NUM.xlsm

نعديل على النعديل Option Explicit Sub SUPER_ADV_FILTER() Application.ScreenUpdating = False Dim i%: i = 4 Dim y$, m%, K% Dim arr Dim MY_Sht As Worksheet Dim ws As Worksheet: Set ws = Sheets("Main") Dim rg As Object Dim rg_to_copy As Range Set rg_to_copy = ws.Range("a3").CurrentRegion Set rg = CreateObject("system.collections.arraylist") Dim lr%: lr = ws.Cells(Rows.Count, 1).End(3).Row With rg Do Until i > lr If Not .contains(CLng(ws.Range("d" & i).Value)) _ And ws.Range("d" & i).Value <> "" Then _ .Add CLng(ws.Range("d" & i).Value) i = i + 1 Loop .Sort For i = 0 To .Count On Error Resume Next y = CStr(.Item(i)) If Len(Sheets(y).Name) = 0 Then Sheets.Add after:=Sheets(Sheets.Count) ActiveSheet.Name = y End If On Error GoTo 0 Next End With Set rg = Nothing For i = 2 To Sheets.Count Sheets(i).Cells.Clear Sheets(i).Range("T1") = "رقم القيد" Sheets(i).Range("T2") = Sheets(i).Name rg_to_copy.AdvancedFilter 2, Sheets(i).Range("T1:T2"), Sheets(i).Range("A3") Sheets(i).Range("T1:T2") = vbNullString Next For Each MY_Sht In Sheets If MY_Sht.Name <> "Main" Then m = 4: K = 1 Do Until MY_Sht.Range("b" & m) = vbNullString MY_Sht.Range("A" & m) = K K = K + 1: m = m + 1 Loop End If Next Application.ScreenUpdating = True End Sub الملف من جديد tarhil_salim_Moreمطور.xlsm

تعديل الماكرو Option Explicit Sub SUPER_ADV_FILTER() Application.ScreenUpdating = False Dim i%: i = 4 Dim y$ Dim arr Dim ws As Worksheet: Set ws = Sheets("Main") Dim rg As Object Dim rg_to_copy As Range Set rg_to_copy = ws.Range("a3").CurrentRegion Set rg = CreateObject("system.collections.arraylist") Dim lr%: lr = ws.Cells(Rows.Count, 1).End(3).Row With rg Do Until i > lr If Not .contains(CLng(ws.Range("d" & i).Value)) _ And ws.Range("d" & i).Value <> "" Then _ .Add CLng(ws.Range("d" & i).Value) i = i + 1 Loop .Sort For i = 0 To .Count On Error Resume Next y = CStr(.Item(i)) If Len(Sheets(y).Name) = 0 Then Sheets.Add after:=Sheets(Sheets.Count) ActiveSheet.Name = y End If On Error GoTo 0 Next End With Set rg = Nothing For i = 2 To Sheets.Count Sheets(i).Cells.Clear Sheets(i).Range("T1") = "رقم القيد" Sheets(i).Range("T2") = Sheets(i).Name rg_to_copy.AdvancedFilter 2, Sheets(i).Range("T1:T2"), Sheets(i).Range("A3") Sheets(i).Range("T1:T2") = vbNullString Next Application.ScreenUpdating = True End Sub الملف tarhil_salim_مطور.xlsm

قم بتغيير اسم الورقة الاولى الى Main يجب ان يكون الجدول بشكل يغهمه الاكسل (لا أعمدة فارغة ) لذلك وضغت صفاً فارغاً بحيث يبدأ الحدول من الصف رقم 3 وجرب هذا الماكرو Option Explicit Sub SUPER_ADV_FILTER() Application.ScreenUpdating = False Dim i%: i = 4 Dim arr Dim ws As Worksheet: Set ws = Sheets("Main") Dim rg As Object Dim rg_to_copy As Range Set rg_to_copy = ws.Range("a3").CurrentRegion Set rg = CreateObject("system.collections.arraylist") With rg Do Until ws.Range("d" & i) = vbNullString If Not .contains(UCase(ws.Range("d" & i).Value)) _ Then .Add UCase(ws.Range("d" & i).Value) i = i + 1 Loop For i = 0 To .Count - 1 On Error Resume Next If Len(Sheets(.Item(i)).Name) = 0 Then Sheets.Add after:=Sheets(Sheets.Count) ActiveSheet.Name = .Item(i) End If On Error GoTo 0 Next End With Set rg = Nothing For i = 2 To Sheets.Count Sheets(i).Range("T1") = "رقم القيد" Sheets(i).Range("T2") = Sheets(i).Name rg_to_copy.AdvancedFilter 2, Sheets(i).Range("T1:T2"), Sheets(i).Range("A3") Sheets(i).Range("T1:T2") = vbNullString Next Application.ScreenUpdating = True End Sub الملف مرفق tarhil_salim.xlsm

اجذف هذا السطر من الكود .Value = Sheets("data").Cells(k, "A")

جرب هذا الماكرو Option Explicit Sub give_data() If ActiveSheet.Name <> "data" Then Exit Sub Dim i%: i = 3 Dim Laste_Row%, k%, m% Dim arr, arr_num() Dim rg As Object arr_num = Array(3, 52, 101, 150, 199, 248, 297, 346, 395, 444) Laste_Row = Sheets("data").Cells(Rows.Count, 1).End(3).Row Sheets("data2").Range("a3").Resize(1000, 3).ClearContents Set rg = CreateObject("system.collections.arraylist") With rg Do Until i > Laste_Row If Not .contains(UCase(Range("g" & i).Value)) Then .Add UCase(Range("g" & i).Value) i = i + 1 Loop arr = .toarray End With For i = LBound(arr) To UBound(arr) m = arr_num(i) For k = 3 To Laste_Row% If Sheets("data").Cells(k, "G") = arr(i) Then With Sheets("data2").Cells(m, 1) .Value = Sheets("data").Cells(k, "A") .Offset(, 1) = Sheets("data").Cells(k, "B") .Offset(, 2) = Sheets("data").Cells(k, "G") m = m + 1 End With End If Next Next Set rg = Nothing: Erase arr_num: Erase arr End Sub الملف مرفق std_salim.xlsm

جرب هذه المعادلة =IF(A1="","",IF(A1="تبليغ","حيث تم تبليغ السيد ","حيث تم تعليق الإنذار هناك"))

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

جرب احد هذين الملفين MyBook.xlsx Date_calcule.xlsx

جرب هذا الماكرو Option Explicit Private Sub Worksheet_Activate() Application.EnableEvents = False Application.ScreenUpdating = False Me.Range("c3") = vbNullString Dim r, c Sheets("ورقة1").Activate r = ActiveCell.Row c = ActiveCell.Column If r > 2 And c = 1 Then Me.Range("c3") = Sheets("ورقة1").Cells(r, c) End If Me.Activate Application.EnableEvents = True Application.EnableEvents = True End Sub الملف مرفق Book100salim.xlsm

جرب هذا الكود Option Explicit Sub Give_sum() Dim My_val Dim i%, s, t# Dim x%: x = Cells(Rows.Count, "d").End(3).Row For i = 4 To x My_val = Split(Range("D" & i), vbLf) My_val = Join(My_val, "+") On Error Resume Next s = Evaluate(My_val) If Err.Number <> 0 Then s = 0 If s = 0 Then Range("D" & i).Offset(, -1) = "Text" Else Range("D" & i).Offset(, -1) = s End If t = t + s Next Range("c" & x + 1) = t End Sub الملف مرفق _salimتجربة.xlsm

جرب هذا الملف _salimحضور و انصراف.xlsm

ربما يكون المطلوب Majmou3at.xlsx

انسخ هذه المعادلة الى الخلية N3 واسحب نزولاً =INDEX($B$2:$L$2,MATCH(MAX($B3:$L3),$B3:$L3,0)) اذا لم تعمل معك استبدل الفاصلة بفاصلة منقوطة (حسب اعدادات الحهاز عندك) لتصبح المعادلة بهذا الشكل =INDEX($B$2:$L$2;MATCH(MAX($B3:$L3);$B3:$L3;0))

جرب هذا الملف يمكنك استبدال الاحرف الاتكليزية بالعربية و ما تريد مقابلها Sum_by_letters.xlsx

1-لم الاجظ اي معادلات بالجداول (الا معادلات الترقيم فب اول عامود من كل جدول) 2- ما هي البيانات المكتملة برأيك في كل جدول (اعني عدد البيانات في كل صف هل هي 5 دون عامود الملاحظات ام 6 مع الملاحظات) 3-الرجاء رفع ملف مختصر قليلاُ (حوالي 20 صف من كل جدول مع بيانات المكتملة و بدون بيانات المكتملة ) حتى يتسنى ملاحظة عمل الكود الذي سيتم وضغه)

يجب اعادة تسمية جميع النطاقات كما فلعت بالتطاف الاول

ممكن ذلك لكن يجب اعادة تسمية النطاقات 1 R_G بدل ان يكون k6:k228 تجويله الى k6 :p228 و هكذا بيقية النطاقات و من ثم استبدال هذين السطرين من الكود Range("c6:c" & Rows.Count).ClearContents Range("c" & m).Resize(r).Value = ara.Value الى Range("c6:G" & Rows.Count).ClearContents Range("c" & m).Resize(r,5).Value = ara.Value

جرب هذا الكود Option Explicit Sub join_data() Dim My_rg As Range Dim m%: m = 6 Dim r% Dim ara Range("c6:c" & Rows.Count).ClearContents Set My_rg = Union(Range("R_G_1"), Range("R_G_2"), Range("R_G_3"), Range("R_G_4")) For Each ara In My_rg.Areas r = ara.Rows.Count Range("c" & m).Resize(r).Value = ara.Value m = m + r + 1 Next End Sub الملف مرفق البيانات_salim.xlsm

موضوع مشابه على هذا العنوان https://www.officena.net/ib/topic/87087-سؤال-للعباقره-بخصوص-الهايبر-لينك/?tab=comments#comment-551173

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

استبدل الحرف Bفي هذا الجزء من المعادلة بالحرف N COUNTIF($O$2:O2;$M$3:$M$200)= $B$3:$B$200

جرب هذا الشيء الكود Option Explicit Sub give_data() Dim My_sh As Worksheet Set My_sh = Sheets("salim") If ActiveSheet.Name <> My_sh.Name Then Exit Sub Dim i As Byte Dim Fasl$ Dim m%: m = 2 With My_sh Dim rg As Range: Set rg = .Range("d3:d6") .Range("B2:b" & Rows.Count).ClearContents For i = 1 To 4 Fasl = rg.Cells(i).Offset(, 1) & " " .Range("b" & m).Resize(rg.Cells(i)) = Fasl m = m + rg.Cells(i) Next End With End Sub الملف tekrar_Salim.xlsm

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