سليم حاصبيا

لا يمكن العمل على هكذا ملف مع هذه الكمية الهائلة من الخلايا المدمجة (كل 4 او 5 أعمدة يشكلون خلية واحدة)

لا أعلم اذا كان هذا المطلوب (لرؤية كافة الصفوف امسح الخلية D2 ) Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Address(0, 0) = "D2" Then using_adV_filter End If Application.EnableEvents = True End Sub '++++++++++++++++++++++++++++++++ Sub using_adV_filter() Dim D As Worksheet Dim S As Worksheet Dim adv_rg As Range Dim Cret As Range Set D = Sheets("Data") Set S = Sheets("Search class") S.Range("A6").CurrentRegion.Clear Set adv_rg = D.Range("A5").CurrentRegion Set Cret = S.Range("D1:D2") adv_rg.AdvancedFilter 2, Cret, S.Range("A6") End Sub saffar.xlsm

تغيير اسماء الصفحات الصفحة الأول "Main" والصفحة الاخيرة "Target"

الملف يعد التصحيح sum attend.xls

تعديل بسيط على الكود مع وضع معادلة مناسبة في العامود Z (يمكن اخفاءه) Private Sub CommandButton2_Click() Dim ws As Worksheet: Set ws = Sheets("inpout1") Dim lr As Integer Dim R, Ahe3b$, Hather$ Ahe3b = "غائب": Hather = "حاضر" ws.Range("w5:w500").ClearContents lr = ws.Range("b" & Rows.Count).End(xlUp).Row For R = 5 To lr ws.Cells(R, "W") = _ Choose(ws.Cells(R, "Z") + 1, Hather, Ahe3b) Next End Sub Khiri.xlsm

تم تعديل التصميم للشيت حيث النتائج (Target) لتبدو اكثر فهماً وصغت معيار النجاج 20 الذي هو 40/2 اذا اردت نغييره يمكن ذلك من خلال الكود (Const Fl_num=20) جرب هذا الكود Option Explicit Sub Get_data() Dim M As Worksheet Dim Tg As Worksheet Dim Max_ro%, i%, n As Byte Dim x%, t% Const Fl_num = 20 Set M = Sheets("Main") Set Tg = Sheets("Target") Max_ro = M.Cells(Rows.Count, 1).End(3).Row M.Range("A4:M" & Max_ro).Interior.ColorIndex = xlNone Tg.Range("B4:M500").Clear Select Case Tg.Range("A1") Case "الدخول": n = 6 Case "اللياقة": n = 7 Case "المهارة": n = 8 Case "الحاسب": n = 9 Case Else: Exit Sub End Select t = 4 For x = 4 To Max_ro If M.Cells(x, n) < Fl_num Then Tg.Cells(t, 2).Resize(, 13).Value = _ M.Cells(x, 1).Resize(, 13).Value ' M.Cells(x, 1).Resize(, 13).Interior.ColorIndex = 35 Union(M.Cells(x, n), M.Cells(x, 2)).Interior.ColorIndex = 35 t = t + 1 End If Next If t > 4 Then With Tg.Range("B4:N" & t - 1) .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 14 .Font.Bold = True End With End If End Sub Youssef Hussein.xlsm

الصور التي رفعتها تبين غير ذلك

جرب هذا الكود Sub AdNumber() Dim Rs As Worksheet Dim FIND_RG As Range On Error GoTo Bay_Bay_Ya_Helween Set Rs = Sheets("الرصيد") Set FIND_RG = Rs.Range("B:B").Find(Rs.Range("L5"), Lookat:=1) If Not FIND_RG Is Nothing Then FIND_RG.Offset(, 5) = _ Val(FIND_RG.Offset(, 5)) + Val(Rs.Range("M5")) Rs.Range("M5") = vbNullString End If Bay_Bay_Ya_Helween: End Sub jassawi.xlsm

هذا الماكرو Private Sub CommandButton2_Click() Dim ws As Worksheet: Set ws = Sheets("inpout1") Dim lr As Integer Dim R, Ahe3b$, Hather$ Ahe3b = "غ": Hather = "حاضر" ws.Range("ai5:ai500").ClearContents lr = ws.Range("b" & Rows.Count).End(xlUp).Row For R = 5 To lr If ws.Cells(R, "B") <> vbNullString Then If Application.CountIf(ws.Cells(R, "H").Resize(, 15), Ahe3b) >= 6 Then ws.Cells(R, "AI") = "غائب" Else ws.Cells(R, "AI") = Hather End If End If Next R End Sub

ممكن ان تكون مخفية تأكد من ذلك شاهد هذا الفيديو لمعرفة ذلك https://www.youtube.com/watch?v=jUBelvb90D8&ab_channel=عمادغازىرحمه

استاذ علي لا ضرورة اكل هذه الحلقات التكرارية (من 4 الى 1000) بكفي حلقة صغيرة جداُ حسب عدد الصفحات(7) كل حلقة تقوم بــ Auto filter على الجدول في الصفحة الرئيسية حسب اسم كل صفحة ثم نسخ الجدول مفلتراً الى الشيت المعنية (لهذا السبب انا طلبت الملف) شيء يشبه هذا الكود Option Explicit Sub filter_Please() Dim arr, Element Dim Rg As Range Set Rg = ActiveSheet.Range("A4").CurrentRegion arr = Array("كهرباء", "ميكانيكا", "نجارة أثاث", _ "زخرفة", "صحي", "إنشاءات", "تشطيبات") For Each Element In arr Rg.AutoFilter , 4, Element Rg.SpecialCells(12).Copy Sheets(Element).Range("A4").PasteSpecial Next ActiveSheet.AutoFilterMode = False End Sub

جرب هذا الملف Nada Task.xlsm

يا اخي ارفع الملف نفسه وليس صورة لا يمكن اكتشاف الخطأ ولا التصحيح على الصورة

See This Video https://www.youtube.com/watch?v=sHm45OFdqwE&ab_channel=قناةساجدةالعزاويالتعليمية

في الخلية D3 اكنب هذه المعادلة واسحب نزولاُ =DATE(YEAR(B3),MONTH(B3),DAY(B3)+C3) abdo.xlsm

في قائمة Dim (قبل ScreenOff) اكتب هذا السطر: $Dim return_Sh

اذا كانت الأعمدة محتلفة هذه المعادلة (الصف الأصفر في الصفحة New sheet ) يمكن استبدال الرقم 500 الى اي عدد تريده =IFERROR(INDEX(Main!$A$2:$BN$500,MATCH($A6,Main!$A$2:$A$500,0),MATCH(B$1,Main!$A$1:$BN$1,0)),"") Smart_vlkup1.xlsm

هل تقصد هذا الشيء مثلاً Option Explicit Function Salim_saerch(rg As Range, N As Integer, Ro As Integer) Dim F_rg As Range Set F_rg = rg.Find(N, lookat:=1) If F_rg Is Nothing Then Salim_saerch = "N/A" Exit Function End If Salim_saerch = IIf(F_rg.Offset(, Ro) = 0, "", F_rg.Offset(, Ro)) End Function Smart_vlookup.xlsm

اتا ارى من الافضل ادراج الاسماء في فائمة منسدلة مطاطة (لا الأرقام) مطاطة اي انها تستجيب لاي تغيير في قائمة الاسماء(نعديل/ اضافة/حذف....) اذا لم تظهر لك القائمة المتسدلة غادر الصفحة (Cerificats) ثم عد اليها مجدداً الملف مرفق Notes.xlsm

حيث انك لم ترفع ملف للمعاينة و من باب التكهن بما تريد اقترح لك هذا الملف degree.xlsm

تعديل رائع و ماذا تريد أكثر من ذلك ؟؟؟؟ لا افهم!.... يجب تغير اتجاه اليوزر (من اليمين لليسار) لتخرج البيانات مرتبة حسب اللغة العربية الصورة الملف مرفق Yasser_R_to_L.xlsm

ممكن العمل على نفس التكست بوكس على ان تختار ( قتدق أو عميل) الكود Private Sub Mot_Change() Dim i As Long, s As Long, LF% Dim Rg As Range Dim Source As Worksheet Dim Rg_to_find As Range Me.ListBox1.Clear If Mot = vbNullString Then Exit Sub Set Source = Sheets("القيود اليوميه 0") LF = Source.Cells(Rows.Count, "F").End(3).Row If LF < 9 Then Exit Sub Select Case True Case Me.Hot.Value Set Rg_to_find = Source.Range("G8:G" & LF) Case Me.Clirnt.Value Set Rg_to_find = Source.Range("F8:F" & LF) Case Else Exit Sub End Select With Me.ListBox1 .AddItem For s = 0 To .ColumnCount - 1 .List(.ListCount - 1, s) = Source.Cells(7, s + 1) Next End With For i = 8 To LF If UCase(Rg_to_find.Cells(i - 7)) Like ("*" & UCase(Mot) & "*") Then With Me.ListBox1 .AddItem For s = 0 To .ColumnCount - 1 .List(.ListCount - 1, s) = Source.Cells(i, s + 1) Next End With End If Next End Sub الملف مرفق Yasser_choise.xlsm

جرب هذا الكود Option Explicit Sub Get_data() Dim M As Worksheet, J As Worksheet Dim LJ_A%, LM_A% Dim col% Dim RM As Range Set M = Sheets("المبيعات اليوميه") Set J = Sheets("اجمالى المبيعات") col = 5 LM_A = M.Cells(Rows.Count, 1).End(3).Row If LM_A = 1 Then Exit Sub LJ_A = J.Cells(Rows.Count, 1).End(3).Row + 1 Set RM = M.Range("A2:E" & LM_A) J.Range("a" & LJ_A).Resize(LM_A - 1, col).Value = _ RM.Value M.Range("A2:E30").ClearContents M.Range("B2:B30").Formula = _ "=IF(A2="""","""",VLOOKUP(A2,aly,2,0))" End Sub الملف مرفق Ali_Hasn.xlsm

This Macro Sub transfer_data() Application.ScreenUpdating = False Dim D As Worksheet Dim array_sheet, Itm Dim Flter_rg As Range, Ro% array_sheet = Array("رصيد", "ديون", "حالص") Set D = Sheets("Data") D.Select Set Flter_rg = D.Range("A2").CurrentRegion For Each Itm In array_sheet With Sheets(Itm) .Range("A2").CurrentRegion.Clear Flter_rg.AutoFilter 9, .Name Flter_rg.SpecialCells(12).Copy .Range("A2").PasteSpecial Ro = Cells(Rows.Count, 1).End(3).Row If Ro > 2 Then .Range("A3").Resize(Ro - 2).Value = _ Evaluate("Row(1:" & Ro - 2 & ")") End If End With Next Itm D.Select D.AutoFilterMode = False Application.ScreenUpdating = True Application.CutCopyMode = False End Sub file included Aziz_filter.xlsm

مع اني لا أحب اليوزر ولا التعامل معه...... الكود المطلوب (كتابة ما تريد حرف أو أكثر في المربع الأصفر) Private Sub Mot_Change() Dim i As Long, s As Long, LF% Dim Rg As Range Dim Source As Worksheet Me.ListBox1.Clear If Mot = vbNullString Then Exit Sub Set Source = Sheets("القيود اليوميه 0") LF = Source.Cells(Rows.Count, "F").End(3).Row If LF < 9 Then Exit Sub With Me.ListBox1 .AddItem For s = 0 To .ColumnCount - 1 .List(.ListCount - 1, s) = Source.Cells(7, s + 1) Next End With For i = 8 To LF If UCase(Source.Cells(i, "F")) Like ("*" & UCase(Mot) & "*") Then With Me.ListBox1 .AddItem For s = 0 To .ColumnCount - 1 .List(.ListCount - 1, s) = Source.Cells(i, s + 1) Next End With End If Next End Sub الملف مرفق Yasser.xlsm