سليم حاصبيا

فقط امسح الخلية J2 واضغط الزر

جرب هذا الكود Option Explicit Sub hid_all() Dim My_num As Single Dim Col As Single Col = Application.Columns.Count Range("B1").Resize(, Col - 1).Columns.Hidden = True If Val(Range("A1")) <= 0 Then My_num = 1 Else My_num = Int(Range("A1")) End If Range("A1") = My_num Range("A1").Resize(, My_num).Columns.Hidden = False End Sub '++++++++++++++++++++++ Sub show_all() Dim Col As Single Col = Application.Columns.Count Range("b1").Resize(, Col - 1).Columns.Hidden = False End Sub الملف مرفق Show_hide_colomns.xlsm

كيف تريد ان يظهر في خلية واجدة محتويات 3 حلايا ادرج مثالاً عمّا تريد

تكتب البيانات في النطاق I1:j50 الغامودين I و J يمكن اخفائها عن غيون الفضوليين ثم تختار في العامود B الرقم الذي تريد

جرب هذا الملف 1- القائمة المنسدلة في الخلية j2 ديناميكية اي انها تستحيب لاي تغيير في الداتا مع عدم تكرار الاسماء Option Explicit '+++++++++++++++++++++++++++++++++++ Private Sub Worksheet_Activate() DATA_VAL End Sub '++++++++++++++++++++++++++++++ Sub DATA_VAL() Dim NT As Worksheet Dim SA As Worksheet Dim RON%, ROS%, i% Set NT = Sheets("NEW_TABLE") Set SA = Sheets("Salary") Dim Dic As Object ROS = SA.Cells(Rows.Count, 1).End(3).Row If ROS < 4 Then Exit Sub Set Dic = CreateObject("Scripting.Dictionary") For i = 4 To ROS If SA.Cells(i, 6) <> "" Then Dic(SA.Cells(i, 6).Value) = "" End If Next If Dic.Count Then With NT.Cells(2, "j").Validation .Delete .Add 3, Formula1:=Join(Dic.keys, ",") End With NT.Cells(2, "j").Value = Dic.keys()(0) End If End Sub '++++++++++++++++++++++++++++++++ Sub Fil_Data() Dim Adr1%, Adr2%, X%, m%, k%, ROS% Dim wat, Ro% Dim Find_rg As Range Dim Band As Range Dim Bol As Boolean Dim NT As Worksheet Dim SA As Worksheet Set NT = Sheets("NEW_TABLE") Set SA = Sheets("Salary") NT.Range("A2").CurrentRegion.Offset(1).Clear If NT.Range("J2") = "" Then Exit Sub wat = NT.Range("J2") m = 3 ROS = SA.Cells(Rows.Count, 6).End(3).Row '+++++++++++++++++++++++++++++++++++++++++ With SA.Range("F3:F" & ROS) Set Find_rg = .Find(What:=wat, LookIn:=xlValues, lookat:=1) If Not Find_rg Is Nothing Then Adr1 = Find_rg.Row: Adr2 = Adr1 Do NT.Range("A" & m).Resize(, 7).Value = _ SA.Range("A" & Adr2).Resize(, 7).Value m = m + 1 Set Find_rg = .FindNext(Find_rg) Adr2 = Find_rg.Row If Adr2 = Adr1 Then Exit Do Loop End If End With If m > 3 Then X = 3 With SA.Range("F3:F" & ROS) Set Find_rg = .Find(What:=NT.Range("F3"), LookIn:=xlValues, lookat:=1) If Not Find_rg Is Nothing Then Adr1 = Find_rg.Row: Adr2 = Adr1 Do Bol = False For k = 8 To 67 If SA.Cells(Adr2, k) <> "" Then Bol = True Exit For End If Next k If Bol Then NT.Cells(X, "H") = SA.Cells(3, k) X = X + 1 End If Set Find_rg = .FindNext(Find_rg) Adr2 = Find_rg.Row If Adr2 = Adr1 Then Exit Do Loop End If End With With NT.Range("A3:H" & m - 1) .Font.Size = 14 .Font.Bold = True .Borders.LineStyle = 1 .InsertIndent 1 .Interior.ColorIndex = 35 End With End If End Sub النلف مرفق RAWATEB.xlsm

جرب هذ الملف (تكتب الارقام في العامود B) SABIL.xlsx

جرب هذا الماكرو 1- الماكرو يظهر معاينة قبل الطباعة من اجل الطياعة مباشرة استيدل السطر Sh.PrintPreview بالسطر Sh.PrintOut Option Explicit Sub Print_all() Dim Sh As Worksheet Dim k% Application.EnableEvents = False Set Sh = Sheets("الربع") Sh.PageSetup.PrintArea = "$B$2:$L$21" For k = 26 To 81 If Sh.Range("C" & k) <> "" Then Sh.Range("D5") = Sh.Range("C" & k) Sh.PrintPreview 'Sh.PrintOut End If Next k Sh.PageSetup.PrintArea = "" Application.EnableEvents = True End Sub الملف مرفق Alaa.xlsm

لا اعلم ما المشكلة عندك ( ظهور علامة التعجب يشير ان الملف يحتوي على ماكرو) لكن عندي يعمل يكل كفاءة ( اضغط على الزر Sort Please) الصورة1 بعد فتج الملف اضغط على الزر (Enable Editing) كما في الصورة 2

جرب هذا النموذج (فقط اضغط على الزر Sort Please) Option Explicit Sub Creezy_Sort() Dim arr, itm, k% Dim txt Dim Col As Object Set Col = CreateObject("System.Collections.Sortedlist") With Sheets("Salim") arr = .Range("A1").CurrentRegion arr = Application.Transpose(arr) .Range("C1").CurrentRegion.ClearContents For Each itm In arr If InStr(itm, ":") Then txt = Split(itm, ":") If UBound(txt) = 1 Then Col.Add CStr(txt(1)), CStr(txt(0)) End If End If Next itm If Col.Count Then For k = 0 To Col.Count - 1 .Cells(1, 3).Offset(k) = _ Col.GetByIndex(k) & ":" & Col.GetKey(k) Next End If End With End Sub الملف مرفق ellatef.xlsm

بعد اذن الاستاذ نزار هذا الكود Option Explicit Sub Fil_Ijasat() Dim Dic As Object, KY Dim I%, lr%, m%, K% Dim txt Dim EE#, FF#, HH#, JJ#, GG#, II#, KK# Dim Source_Sheet As Worksheet Dim Target_Sheet As Worksheet Dim Cur_Value Set Source_Sheet = Sheets("Sheet1") Set Target_Sheet = Sheets("Sheet2") Set Dic = CreateObject("Scripting.Dictionary") lr = Source_Sheet.Cells(Rows.Count, 2).End(3).Row Target_Sheet.Range("a3:k100").ClearContents If lr < 4 Then Exit Sub For I = 4 To lr txt = Source_Sheet.Cells(I, 2).Resize(, 3) txt = Application.Transpose(txt) txt = Application.Transpose(txt) txt = Join(txt, "*") Dic(txt) = Dic(txt) + Val(Source_Sheet.Cells(I, 7)) Next I If Dic.Count Then m = 3 For Each KY In Dic Target_Sheet.Cells(m, 1) = m - 2 Target_Sheet.Cells(m, 2).Resize(, 3).Value = _ Split(KY, "*") m = m + 1 Next KY End If Set Dic = Nothing If m > 3 Then For I = 3 To m - 1 For K = 4 To lr If Target_Sheet.Cells(I, 2) = Source_Sheet.Cells(K, 2) Then Cur_Value = Val(Source_Sheet.Cells(K, 7)) Select Case Trim(Source_Sheet.Cells(K, 8)) Case "اعتيادي": EE = EE + Cur_Value Case "عارضة": FF = FF + Cur_Value Case "اذن": HH = HH + Cur_Value Case "تناوب": JJ = JJ + Cur_Value Case "انقطاع": GG = GG + Cur_Value Case "راحة": II = II + Cur_Value Case "مرضي": KK = KK + Cur_Value End Select End If Next K With Target_Sheet.Cells(I, 5) .Value = IIf(EE = 0, "", EE) .Offset(, 1) = IIf(FF = 0, "", FF) .Offset(, 2) = IIf(GG = 0, "", GG) .Offset(, 3) = IIf(HH = 0, "", HH) .Offset(, 4) = IIf(II = 0, "", II) .Offset(, 5) = IIf(JJ = 0, "", JJ) .Offset(, 6) = IIf(KK = 0, "", KK) End With EE = 0: FF = 0: GG = 0: HH = 0 II = 0: JJ = 0: KK = 0 Next I End If End Sub الملف مرفق Ijasat.xlsm

عندي يعمل بشكل طبيعي انظر الضورة seaf Extra1.xlsm

تم التعديل على الملف ليتناسب مع المطلوب 1- تضع نوع الاجازة مباشرة امام اسم الموظف في التاريخ المناسب ثم تضغط على الزر Get Vacation الخلايا لا تقيل الا القيم M من اجل Medical leaves / او V من اجل Vacation A من اجل Absence / او U من اجل Unpaid H من اجل Official holiday / او P من اجل pay E من اجل emergency leave الكود لاجل ايام العطلة Sub Fil_Suumation() Dim Dic As Object, KY Dim I%, y%, Col% Set Dic = CreateObject("Scripting.Dictionary") With Sheets("Repport") lr = .Cells(Rows.Count, 3).End(3).Row If lr < 9 Then Exit Sub .Range("AO9").Resize(100, 8).ClearContents For I = 9 To lr For y = 10 To 38 If .Cells(I, y) <> "" Then Dic(UCase(.Cells(I, y).Value)) = "" End If Next y If Dic.Count Then For Each KY In Dic Select Case KY Case "M": Col = 41 Case "V": Col = 42 Case "A": Col = 43 Case "U": Col = 44 Case "H": Col = 45 Case "P": Col = 46 Case "E": Col = 47 End Select .Cells(I, Col) = _ Application.CountIf(.Cells(I, "j").Resize(, 31), KY) Next KY Range("AV" & I) = Application.Sum(.Range("AO" & I).Resize(, 7)) End If Dic.RemoveAll Next I End With End Sub الملف من جديد seaf Extra.xlsm

مبدئياُ هذا الكود لادراج التواريخ لكل شهر ما عدا يوم الجمعة 1- هناك صفوف واعمدة فارغة( مخفية) لفضل الجدول عن بقية البيانات (الصف رقم 8 والاعمدة I و AM ) 2-نوع الاجازات في عامود واحد (H) لا تنقع لأنه يمكن للموظف ان يأخذ نوعين (أو اكثر) من الاجازات مثلا من تاريخ 1 الى 5 اجازة مرضية و من تاريخ 20 الى 23 اجازة خاصة الكود (صفحة Repport) Option Explicit Sub Get_Date() Dim Start_date As Date Dim End_date As Date Dim k%, xx, lr% With Sheets("Repport") lr = .Cells(Rows.Count, 3).End(3).Row If lr < 9 Then Exit Sub .Range("N9:N" & lr).ClearContents If Not IsDate(.Range("M3")) Then Start_date = #1/1/2021# .Range("M3") = Start_date Else Start_date = .Range("M3") End If End_date = Application.EoMonth(.Range("M3"), 0) .Range("U3") = End_date k = 10 .Range("j6").Resize(2, 31).ClearContents For xx = Start_date To End_date If Format(Day(xx), "dddd") <> "Friday" Then .Cells(7, k) = Day(xx) .Cells(6, k) = Format(Day(xx), "dddd") k = k + 1 End If Next .Range("AN9:AN" & lr) = _ Application.Count(.Range("j7").Resize(, 31)) End With End Sub الملف مرفق seaf mohamed.xlsm

جرب هذا الكود Option Explicit Private Sub TextBox1000_Change() Dim x As Worksheet Dim c As Range Dim Arr_Sh, Itm Dim k%,b% Arr_Sh = Array("BB") ''يمكن هنا اضافة اسماء الشيتات التي تريد البحث فيها If TextBox1000.Value = "" Then ListBox1.Clear: Exit Sub Dim x As Worksheet Dim c As Range ListBox1.Clear k = 0 For Each Itm In Arr_Sh Set x = Sheets(Itm) ss = x.Cells(Rows.Count, 9).End(xlUp).Row If ss < 9 Then GoTo Next_Item For Each c In x.Range("A9:A" & ss) b = InStr(c, TextBox1000) If Trim(c) Like TextBox1000 & "*" Then ListBox1.AddItem ListBox1.List(k, 0) = x.Cells(c.Row, 1) ListBox1.List(k, 1) = Itm ListBox1.List(k, 2) = c.Row k = k + 1 End If Next c Next_Item: Next Itm End Sub

ما هو اسم الشيت التي تريد البحث فيها؟؟؟

in the Cell I3 this formula,and drag 3 columns to right,Until Row 121 =VLOOKUP($H3,'Data base'!$B$4:$E$69,COLUMNS($A$1:B1),0) File Included mr7mix.xlsx

وهل من المفروض على من سيقوم بالمساعدة ان ينشأ لك ملفاً بما تريد؟ ام عليك رفع الملف بنفسك على كل حال اليك هذا النموذج يحتوي على 2 ماكرو واحد للقوائم المنسدلة والاحر لادراج الاسماء 10 : 10 الماكرو ديناميكي (اي انه يحصي كل الاسماء مهما كان عددها) (كل مجموعة مرتية ابجدياُ) Option Explicit Sub Get_data_val() Const t = 10 Dim obj As Object Dim lr%, i%, m%, k%, Cnt% Dim arr Dim My_rg As Range If ActiveSheet.Name <> "Sheet1" Then Exit Sub k = 3 lr = Cells(Rows.Count, 1).End(3).Row Set obj = CreateObject("System.Collections.Arraylist") For i = 2 To lr Step t Set My_rg = Cells(i, 1).Resize(t) Cnt = Application.CountA(My_rg) Set My_rg = My_rg.Cells(1, 1).Resize(Cnt) Do Until m = Cnt obj.Add My_rg.Cells(m + 1, 1).Value m = m + 1 Loop If obj.Count Then obj.Sort With Cells(2, k).Validation .Delete .Add 3, Formula1:=Join(obj.Toarray, ",") Cells(2, k) = obj(0) End With End If k = k + 1: m = 0 obj.Clear Next i End Sub '++++++++++++++++++++++++++++++++++ Sub Get_By_10() Const t = 10 Dim obj As Object Dim lr%, i%, m%, k%, Cnt% Dim My_rg As Range If ActiveSheet.Name <> "Sheet1" Then Exit Sub k = 3 lr = Cells(Rows.Count, 1).End(3).Row Set obj = CreateObject("System.Collections.Arraylist") Cells(5, 3).CurrentRegion.Offset(1).ClearContents For i = 2 To lr Step t Set My_rg = Cells(i, 1).Resize(t) Cnt = Application.CountA(My_rg) Set My_rg = My_rg.Cells(1, 1).Resize(Cnt) Do Until m = Cnt obj.Add My_rg.Cells(m + 1, 1).Value m = m + 1 Loop If obj.Count Then obj.Sort Cells(5, k).Resize(obj.Count) = _ Application.Transpose(obj.Toarray) End If k = k + 1: m = 0 obj.Clear Next i End Sub الملف مرفق Kaissi.xlsm

لا افهم كيف بامكان خلية واحدة ان تظهر نتيجة اكثر من معادلة واحدة المعادلات المطلوبة في العامود N Nassim.xls

الملف من جديد مع اختيار التاريخ من الى في الحلايا L2 و M2 في حال الخطأ بكتابة التواريخ في L2 او M2 او ادراح تواريخ غير موجودة في البيانات يقوم الماكرو بادراج كل التواريخ من اصغرها الى اكبرها اذا كنت تريد يوما واجداً اجعل L2 و M2 متساويتين (مثلا لاختيار 10 ابريل اكتب 10/4/2021 في L2 و M2) Option Explicit Sub All_In_One() Dim SH(), itm, My_sh As Worksheet Dim T As Worksheet Dim Sb#, Sc#, Sd#, Se#, Sf#, Sg# Dim ads%, k%, n%, Ro%, Max_row% Dim X As Date Dim Dat1 As Date, Dat2 As Date Dim F_rg As Range, Wat Set T = Sheets("Total") Max_row = Sheets("Reg1").Cells(Rows.Count, 1).End(3).Row If Not IsDate(T.Range("L2")) Or _ IsError(Application.Match(T.Range("L2"), _ Sheets("Reg1").Range("A3:A" & Max_row), 0)) Or _ IsError(Application.Match(T.Range("M2"), _ Sheets("Reg1").Range("A3:A" & Max_row), 0)) Then Dat1 = Application.Min(Sheets("Reg1").Range("A3:A" & Max_row)) Dat2 = Application.Max(Sheets("Reg1").Range("A3:A" & Max_row)) T.Range("L2") = Dat1: T.Range("M2") = Dat2 Else Dat1 = Application.Min(T.Range("L2"), T.Range("M2")) Dat2 = Application.Max(T.Range("L2"), T.Range("M2")) T.Range("L2") = Dat1: T.Range("M2") = Dat2 End If k = T.Cells(Rows.Count, 1).End(3).Row If k < 3 Then Exit Sub T.Range("A3").Resize(k - 2, 7).ClearContents SH = Array("Reg1", "Reg2", "Reg3", "Reg4", "Reg5") For X = Dat1 To Dat2 T.Range("A3").Offset(n) = Dat1 + n n = n + 1 Next k = T.Cells(Rows.Count, 1).End(3).Row For n = 3 To k Wat = T.Range("A" & n) For Each itm In SH Set My_sh = Sheets(itm) Ro = My_sh.Cells(Rows.Count, 1).End(3).Row If Ro < 3 Then GoTo Next_Itm Set F_rg = My_sh.Range("A2:A" & Ro).Find(Wat, Lookat:=1) If F_rg Is Nothing Then GoTo Next_Itm ads = F_rg.Row Sb = Sb + Val(My_sh.Cells(ads, "B")) Sc = Sc + Val(My_sh.Cells(ads, "C")) Sd = Sd + Val(My_sh.Cells(ads, "D")) Se = Se + Val(My_sh.Cells(ads, "E")) Sf = Sf + Val(My_sh.Cells(ads, "F")) Sg = Sg + Val(My_sh.Cells(ads, "G")) Next_Itm: Next itm With T.Cells(n, 2) .Value = Sb: Sb = 0 .Offset(, 1) = Sc: Sc = 0 .Offset(, 2) = Sd: Sd = 0 .Offset(, 3) = Se: Se = 0 .Offset(, 4) = Sf: Sf = 0 .Offset(, 5) = Sg: Sg = 0 End With Next n End Sub الملف من جديد Hasan_Choise.xlsm

ممكن ان يكون المطلوب ASD200.xlsm

تم تعديل اسماء الضفحات الى Reg اي Region وذلك من اجل حسن نسخ الكود ولصقه دون مشاكل اللغة العربية وطهور أحرف غريبة فيه فقط اضغط الزر Run Option Explicit Sub All_In_One() Dim SH(), itm, My_sh As Worksheet Dim T As Worksheet Dim Ro%, Sb#, Sc#, Sd#, Se#, Sf#, Sg#, k%, n% Dim ads% Dim F_rg As Range, Wat Set T = Sheets("Total") k = T.Cells(Rows.Count, 1).End(3).Row If k < 3 Then Exit Sub T.Range("B3").Resize(k - 2, 6).ClearContents SH = Array("Reg1", "Reg2", "Reg3", "Reg4", "Reg5") For n = 3 To k Wat = T.Range("A" & n) For Each itm In SH Set My_sh = Sheets(itm) Ro = My_sh.Cells(Rows.Count, 1).End(3).Row If Ro < 3 Then GoTo Next_Itm Set F_rg = My_sh.Range("A2:A" & Ro).Find(Wat, Lookat:=1) If F_rg Is Nothing Then GoTo Next_Itm ads = F_rg.Row Sb = Sb + Val(My_sh.Cells(ads, "B")) Sc = Sc + Val(My_sh.Cells(ads, "C")) Sd = Sd + Val(My_sh.Cells(ads, "D")) Se = Se + Val(My_sh.Cells(ads, "E")) Sf = Sf + Val(My_sh.Cells(ads, "F")) Sg = Sg + Val(My_sh.Cells(ads, "G")) Next_Itm: Next itm With T.Cells(n, 2) .Value = Sb: Sb = 0 .Offset(, 1) = Sc: Sc = 0 .Offset(, 2) = Sd: Sd = 0 .Offset(, 3) = Se: Se = 0 .Offset(, 4) = Sf: Sf = 0 .Offset(, 5) = Sg: Sg = 0 End With Next n End Sub الملف مرفق Hasan.xlsm

في الخلية B3 من الصفجة (اجمالي يومي) اكتب هذه المعادلة( كما في الصورة) ثم اسحب يساراً 6 اعمدة و نزولا حتى الصف 89 الملف مرفق Hasan.xlsx

جرب هذا الكود Option Explicit Private Sub CommandButton1_Click() Dim My_Format$ Dim I As Byte My_Format = "#,##0.00" With Sheets("TEST") For I = 1 To 4 Me.Controls("TextBox" & I) = _ Format(.Range("A3").Offset(I - 1), My_Format) Next End With End Sub

لا تقم بالقسمة على 100

في شيت CHASH INVOICE وضعت زر الحفظ لحفظ الفاتورة اريد تفعيله في الاكسل لا تستطيع حفظ ورقة (او جزء منها) الحفظ بتم على المصنف بـأكمله