سليم حاصبيا

للتعديل قم بتسمية زر التعديل بـــ Cmd_UPdate كما في الصورة الكود اللازم Private Sub Cmd_UPdate_Click() Dim Arr(5), Itm, FR As Range Arr(0) = "T_B": Arr(1) = "T_C":: Arr(2) = "T_D" Arr(3) = "T_E": Arr(4) = "T_F": Arr(5) = "T_G" First_Of_all If Me.Where = vbNullString Or _ Val(Me.Where) <= 0 Then MsgBox "ادخل رقم تاكيد الحجز" Exit Sub End If Set FR = ws.Range("A8:A" & lr) _ .Find(CInt(Me.Where), lookat:=1) If FR Is Nothing Then MsgBox "No data" Else With ws.Cells(FR.Row, 2) For i = 0 To UBound(Arr) .Offset(, i) = Me.Controls(Arr(i)) Next End With End If

لم افهم عليك ما تريد ربما كان هذا المطلوب If_Tow.xlsx

تم تفعيل زر الحذف مع ادراج التاريخ بالتنسيق كما تريده Private Sub Cmd_Del_Click() First_Of_all Dim FR As Range If Val(Me.Where) <= 0 Then Else Set FR = ws.Range("A8:A" & lr) _ .Find(CInt(Me.Where), lookat:=1) If FR Is Nothing Then MsgBox "I can't Find That " _ & """" & Me.Where & """" & " In Column A" Exit Sub Else ws.Cells(FR.Row, 1).Resize(, 7).Delete lr = ws.Cells(Rows.Count, 2).End(3).Row ws.Range("a10").Resize(lr - 9) = _ Evaluate("Row(1:" & lr - 9 & ")") End If Me.Where = CInt(Me.Where) End If End Sub yasse.w._1.xlsm

هذه المعادلة =IF(ISNA(MATCH(C16,$C$10:$K$10,0)),"No Matching",INDEX($C$11:$K$11,MATCH(C16,$C$10:$K$10,0))) My_if.xlsx

ربما يكون المطلوب Option Explicit Dim ws As Worksheet Dim lr%, i% Sub First_Of_all() Set ws = ActiveSheet lr = ws.Cells(Rows.Count, 2).End(3).Row End Sub '+++++++++++++++++++++++++++++++++++++++ Private Sub Cmd_Saech_Click() Dim Arr(5), Itm, FR As Range Arr(0) = "T_B": Arr(1) = "T_C":: Arr(2) = "T_D" Arr(3) = "T_E": Arr(4) = "T_F": Arr(5) = "T_G" First_Of_all If Me.Where = vbNullString Or _ Val(Me.Where) <= 0 Then MsgBox "Please Type Correct Number" Exit Sub End If Set FR = ws.Range("A8:a" & lr) _ .Find(CInt(Me.Where), lookat:=1) If FR Is Nothing Then MsgBox "No data" Else With ws.Cells(FR.Row, 2) For i = 0 To UBound(Arr) Me.Controls(Arr(i)) = .Offset(, i) Next End With End If End Sub '+++++++++++++++++++++++++++++++++ Private Sub Cmd_Tarhil_Click() Dim CTr As Control, Bol As Boolean Dim Arr(5), Itm Arr(0) = "T_B": Arr(1) = "T_C":: Arr(2) = "T_D" Arr(3) = "T_E": Arr(4) = "T_F": Arr(5) = "T_G" First_Of_all For Each CTr In Me.Controls If CTr.Name Like "T_*" _ And CTr = vbNullString Then Bol = True: Exit For End If Next If Bol Then MsgBox "Please Fill all TextBoxes To countinous" Exit Sub End If With ws.Cells(lr + 1, 2) For i = 0 To UBound(Arr) .Offset(, i) = Me.Controls(Arr(i)) Me.Controls(Arr(i)) = vbNullString Next End With MsgBox "That's ALL", vbInformation, "ADmin" Unload Me End Sub yasse.w.xlsm

هذه المعادلة =TEXT(C4,"hh:mm")&"-"&TEXT(C5,"hh:mm") و اذا لم تعمل معك استبدل الفاصلة "," بفاصلة " ; " منقوطة لتبدو هكذا =TEXT(C4;"hh:mm")&"-"&TEXT(C5;"hh:mm")

جرب هذا الملف 1- العامودين B و C يدرج فيهما التسلسل و اسماء الحساب (بدون اكرار) 2-التاريخ في الخلايا D2 & D1 يدرج في قوائم منسدلة (دون تكرار) 3 -اذا لم تدرج هذه المغلومات غادر الصفحة Repport ثم عد اليها 4- أخنر التاريحين من D1 و D2 واضغط الزر Run Option Explicit Dim Mx As Date, Mn As Date Dim D As Worksheet, R As Worksheet Dim Rg_D As Range, Rg_R As Range Dim Ro_d%, Ro_R%, m% Dim Dic_date As Object Dim Dic_F As Object Sub Begin() Set D = Sheets("data"): Set R = Sheets("Repport") Ro_d = D.Cells(Rows.Count, 3).End(3).Row Ro_R = R.Cells(Rows.Count, 2).End(3).Row If Ro_R < 6 Then Ro_R = 6 End Sub '+++++++++++++++++++++++++++ Sub Crete_val_data() Dim i% Begin If Ro_d < 4 Then Exit Sub Set Dic_date = CreateObject("Scripting.Dictionary") Set Dic_F = CreateObject("Scripting.Dictionary") For i = 4 To Ro_d If IsDate(D.Cells(i, 3).Value) Then Dic_date(D.Cells(i, 3).Value) = vbNullString Dic_F(D.Cells(i, 7).Value) = vbNullString End If Next With R.Range("D1:D2").Validation .Delete .Add 3, Formula1:=Join(Dic_date.keys, ",") End With R.Range("C6").Resize(Dic_F.Count) = _ Application.Transpose(Dic_F.keys) R.Range("B6").Resize(Dic_F.Count).Value = _ Evaluate("Row(1:" & Dic_F.Count & ")") End Sub '+++++++++++++++++++++++++++++++++++ Sub get_Data() Begin Dim x x = R.Cells(Rows.Count, 2).End(3).Row R.Cells(6, 4).Resize(x - 5, 2).Formula = _ "=SUMPRODUCT(--(data!$C$4:$C$100<=$D$2),--(data!$C$4:$C$100>=$D$1),--(data!$G$4:$G$100=$C6),(IF(ISNUMBER(data!D$4:D$100),(data!D$4:D$100),0)))" R.Cells(6, 6).Resize(x - 5).Formula = _ "=SUM(D6,-E6)" R.Cells(6, 2).CurrentRegion.Value = _ R.Cells(6, 2).CurrentRegion.Value End Sub الملف مرفق Raad.xlsm

الكود كما يجب ان يكون (ثم ان اليوزر عريض بشكل لا تستطيع ان تراه بأكمله على الــ Vb Editor) التقليل من عرضه و عرض الليست بوكس (مع اني لا أحب اليوزر ولا أطيق النعامل معه) Private Sub CommandButton1() Dim i As Long, s As Long, LF% Dim Rg As Range Dim Source As Worksheet Dim Rg_to_find As Range Dim Mot For Each ctl In Me.Controls If TypeName(ctl) = "OptionButton" Then If ctl.Value = True Then Mot = ctl.Name Exit For End If End If Next ctl Set Source = Sheets("القيود اليوميه 0") LF = Source.Cells(Rows.Count, "F").End(3).Row If LF < 9 Then Exit Sub Select Case True Case Mot = "kod": Set Rg_to_find = Source.Range("C8:C" & LF) Case Mot = "mosm": Set Rg_to_find = Source.Range("D8:D" & LF) Case Mot = "Clirnt": Set Rg_to_find = Source.Range("F8:F" & LF) Case Mot = "pyan": Set Rg_to_find = Source.Range("H8:H" & LF) Case Mot = "Hot": Set Rg_to_find = Source.Range("G8:G" & LF) Case Mot = "madin": Set Rg_to_find = Source.Range("I8:I" & LF) Case Mot = "daen": Set Rg_to_find = Source.Range("J8:J" & LF) Case Mot = "snd": Set Rg_to_find = Source.Range("b8:b" & LF) Case Mot = "ced": Set Rg_to_find = Source.Range("A8:A" & 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

اذا كان هناك فراغات يمكن ان نتجاوزها بهذا الكود و لا لزوم لما لا يلزم من وضع 2 Arrays واحد لكل شيت Option Explicit Sub All_in_One() Dim First As Worksheet Dim arr(1), Sh, i%, x% Dim dic As Object Set First = Sheets("Sheet1") Set dic = CreateObject("Scripting.Dictionary") arr(0) = "Sheet2": arr(1) = "Sheet3" First.Range("B1").CurrentRegion.ClearContents For Each Sh In arr x = Sheets(Sh).Cells(Rows.Count, 2).End(3).Row i = 2 Do Until i > x If Sheets(Sh).Range("B" & i) <> "" Then dic(Sheets(Sh).Range("B" & i).Value) = vbNullString End If i = i + 1 Loop Next Sh If dic.Count Then First.Range("B2") = "Names" First.Range("B3").Resize(dic.Count) = _ Application.Transpose(dic.keys) First.Range("A3").Resize(dic.Count) = _ Evaluate("Row(1:" & dic.Count & ")") End If Set dic = Nothing: Set First = Nothing Erase arr End Sub

جرب هذا الماكرو ( لا صفوف فارغة في الجداول لان الماكرو يتوقف عند أول حلية فارغة) Option Explicit Sub All_in_One() Dim First As Worksheet Dim arr(1), Sh, i% Dim dic As Object Set First = Sheets("Sheet1") Set dic = CreateObject("Scripting.Dictionary") arr(0) = "Sheet2": arr(1) = "Sheet3" First.Range("B1").CurrentRegion.ClearContents For Each Sh In arr i = 3 Do Until Sheets(Sh).Range("B" & i) = vbNullString dic(Sheets(Sh).Range("B" & i).Value) = vbNullString i = i + 1 Loop Next Sh If dic.Count Then First.Range("B2") = "Names" First.Range("B3").Resize(dic.Count) = _ Application.Transpose(dic.keys) First.Range("A3").Resize(dic.Count) = _ Evaluate("Row(1:" & dic.Count & ")") End If Set dic = Nothing: Set First = Nothing Erase arr End Sub الملف مرفق Muneef.xlsm

وزيادة في اثراء الموضوع هذه المعادلة(Ctrl+Shift+Enter) وليس Enter وجدها =SUM(IF(ISNUMBER(SEARCH($F10,C$2:C$15)),1,0)) الملف مرفق Moham9.xlsx

بدون ملف مرفق لا احد يستطيع المساعدة لكن يمكنك اختبار هذا التموذج Abou sadd.xlsm

لا أعرف سبب التركيز على الحلقات التكرارية في أكثر الاكواد في حين يمكن عمل ذلك بواسطة فلتر بسيط Option Explicit Sub test_salim() Dim ws As Worksheet Dim ws2 As Worksheet Set ws = Sheets("البيانات") Set ws2 = Sheets("التقرير") If ActiveSheet.Name <> ws2.Name Then ws2.Select ws.AutoFilterMode = 0 ws2.Range("A10").CurrentRegion.Clear ws.Range("A9").CurrentRegion.AutoFilter 1, ws2.[c2] ws.Range("A10").SpecialCells(12).Copy ws2.Range("A10").PasteSpecial (8) ws2.Range("A10").PasteSpecial (11) Application.CutCopyMode = 0 ws.AutoFilterMode = 0 End Sub

لك ما تريد hicham26.xlsx

أولاً لا ضرورة لهذه التنسيفات والزركشة يالألوان المبهرة التي تجعل الملف ثقيلاً ثانياً ما الحاجة التي دمج الخلايا التي تعيق عمل الكود ثالثأً العمل بجب ان يكون كما في المرفق ( اضغط الزر OK ) و تنتقل البيانات الى الشيت Data مع حبار التبديل اذا كان الشحص مسجلاً Option Explicit Sub Get_date_and_time() Dim M As Worksheet, D As Worksheet Dim Rg_M As Range, Rg_D As Range Dim find_me As Range Dim Ro%, Answer As Byte Set M = Sheets("Main"): Set D = Sheets("Data") Set Rg_M = M.Range("D3:D7") Set Rg_D = D.Range("B1:B34") Set find_me = Rg_D.Find(Rg_M.Cells(2), lookat:=1) If find_me Is Nothing Then MsgBox "This Name " & Rg_M.Cells(2, 2) & "Not Exist" Exit Sub Else Ro = find_me.Row If Rg_D.Cells(Ro).Offset(, 1) <> "" Then Answer = MsgBox("This person " & """" & _ Rg_M.Cells(2, 2) & """" & " is registered" & Chr(10) & _ "Do you want to change", vbYesNo) If Answer = 6 Then D.Cells(Ro, 3) = Format(M.Cells(6, 4), "dd-mm-yyy") D.Cells(Ro, 4) = Format(M.Cells(7, 4), "hh : mm") Exit Sub End If End If D.Cells(Ro, 3) = Format(M.Cells(6, 4), "dd-mm-yyy") D.Cells(Ro, 4) = Format(M.Cells(6, 4), "hh : mm") End If End Sub Shalapy.xlsm

كبف تقوم باستعمال دالة مرتبطة بشيت غير موجود (عبدالرحمن الغرابلي)

عليك ادراج نفس اسم الزر في الكود كما هو في قائمة (Properties) لاحظ الصورة

كود لجلب الاسماء اوتوماتيكياُ الى ComboBox دون تكرار اختر الاسم والتاريخ واضغط بحث Option Explicit Private Sub CommandButton2_Click() Unload Me End Sub '+++++++++++++++++++++++++++++++++ Private Sub Cmd_Search_Click() Dim x, K As Long, bol As Boolean Dim My_date As Date, Ctr As Control x = Sheets("Main").Cells(Rows.Count, 2).End(3).Row Txt_B = "": Txt_C = "": Txt_D = "": Txt_E = "": Txt_F = "" If Comb_Name = "" Or T_date = "" Then MsgBox "Please Type Name and Date": Exit Sub Else My_date = CDate(T_date) For I = 2 To x With Sheets("Main").Cells(I, 2) If .Value = Comb_Name And _ .Offset(, 3) = My_date Then bol = True Txt_B = .Value: Txt_C = .Offset(, 1) Txt_D = .Offset(, 2): Txt_E = .Offset(, 3) Txt_F = .Offset(, 4): Exit Sub End If End With Next End If If Not bol Then MsgBox "No data" End If End Sub '++++++++++++++++++++++++++++++++++++++++++++ Private Sub UserForm_Initialize() Dim a%, I% a = Sheets("Main").Cells(Rows.Count, 2).End(3).Row With CreateObject("Scripting.Dictionary") For I = 2 To a .Item(Sheets("Main").Cells(I, 2).Value) = Empty Next I Comb_Name.List = .Keys End With End Sub Fathi_combo.xlsm

جرب هذا الكود تم تغيير اسم الصفحة الرئيسية الى اللغة الأجنبية (Central) لسهولة نسخ الكود ولصقة (دون ظهور احرف غريبة فيه) Option Explicit Sub One_For_all() Dim Ar_sheet() Dim m%, x%, Ro%, Itm, ct_ro% Dim Rg As Range, CT As Worksheet Dim ct_rg As Range Dim Var_rg As Range, var_ro%, var_col% Application.ScreenUpdating = False Set CT = Sheets("Central") Set ct_rg = CT.Range("A1").CurrentRegion ct_ro = ct_rg.Rows.Count If ct_ro > 1 Then ct_rg.Offset(1).Resize(ct_ro - 1).Clear End If For m = 0 To Sheets.Count - 1 If Sheets(m + 1).Name <> CT.Name Then ReDim Preserve Ar_sheet(m) Ar_sheet(m) = Sheets(m + 1).Name End If Next m = 2 For Each Itm In Ar_sheet Set Var_rg = Sheets(Itm).Range("A1").CurrentRegion var_ro = Var_rg.Rows.Count var_col = Var_rg.Columns.Count If var_ro > 1 Then CT.Cells(m, 2).Resize(var_ro - 1, var_col - 1).Value = _ Sheets(Itm).Range("B2") _ .Resize(var_ro - 1, var_col - 1).Value m = m + var_ro - 1 End If Next Itm If m > 2 Then With CT.Range("A2").Resize(m - 2, var_col) .Columns(1) = Evaluate("Row(1:" & m - 2 & ")") .Borders.LineStyle = 1 .InsertIndent 1 .Font.Bold = True .Font.Size = 14 .Interior.ColorIndex = 35 End With End If Application.ScreenUpdating = True End Sub الملف مرفق Moustafa7.xlsm

جرب هذه المعادلة (Crtl+Shift+Enter) وليس Enter وجدها =VLOOKUP(SUM(IFERROR(IF(ISNUMBER(FIND({"Can limon";"Rosie"},A3)),ROW($A$1:$A$12),""),"")),{0,0;1,100;2,70},2,0) File included vlk_Find.xlsx

هناك معادلة اسهل =COUNTIF($M$44:$M$59,I4)>0

تفضل هذا الماكرو صفحة RESULT من هذا الملف Option Explicit Sub GET_DATA() Sheets("RESULT").Range("B3").CurrentRegion.Clear With Sheets("DATA SOURCE") .AutoFilterMode = False .Range("B3").CurrentRegion.AutoFilter 7, Criteria1:="=" & "*/*" .Range("B3").CurrentRegion.SpecialCells(12).Copy Sheets("RESULT").Range("B3").PasteSpecial (8) Sheets("RESULT").Range("B3").PasteSpecial .AutoFilterMode = False End With End Sub الملف مرفق (اضغط الزر Run فقط) Dates.xlsm

تعديل بالنسبة للغة الأجنبيىة كل شيء تمام (لا مشاكل في الاسطر الفارغة) بالنسبة للغة العربيى هناك مشكلة بالصفوف الفارعة (ولا أعرف طريقة حلها) List_box52.xlsm

و من أين لي ان اعرف ماذا تريد ان تكتب في التكست بوكس؟؟؟؟ على كل حال ضع النص الذي تريده داخل الكود

الكود المطلوب Dim st Private Sub CommandButton1_Click() With Sheets("Salim").Range("A1") .Range("A1").ClearContents .Value = st End With End Sub '+++++++++++++++++++++++++++++++++ Private Sub UserForm_Initialize() st = "الأهداف:" & Chr(10) & _ Space(5) & "1 - تحديد مفهومي مفاتيح الأداء و مفاتيح التأطير و دواعي العمل بهما" & Chr(10) & _ Space(5) & "2 - تحليل بعض الكفاءات الختامية باعتماد مفاتيح التأطير و مفاتيح الأداء" & Chr(10) & _ Space(5) & "3 - دواعي وضع مناهج جديدة ( مناهج الجيل الثاني ) " TextBox1.Text = st End Sub الملف مرفق List_box51.xlsm