سليم حاصبيا

للاسف ليس هناك دالة لهذا الامر(حسب علمي) لأن الدالة sum تتجاهل الخلية (بالكامل) التي تحتوي على نص و ليس محتوباتها و ريثما تقوم مايكروسوف باختراع هكذا دالة ما علينا الا العمل بواسطة الــ VBA

جرب هذا الملف فقط اضغط الزر Run الكود Option Explicit Rem code for Extact Number_From_Text Sub Extract_Number_Please() Dim rgx As Object Dim My_Number As Object Dim ws As Worksheet Dim i%, m%, k%, x%, Ro% Dim My_sum#, Big_sum# Set rgx = CreateObject("VBScript.RegExp") Set ws = Worksheets("Salim") Ro = ws.Cells(Rows.Count, 2).End(3).Row m = 2: k = 4 ws.Cells(m, k).CurrentRegion.Clear With rgx .Global = True: .Pattern = "(\d+\.?\d+)" For i = 2 To Ro If .Test(ws.Cells(i, 2)) Then Set My_Number = .Execute(ws.Cells(i, 2)) For x = 0 To My_Number.Count - 1 My_sum = My_sum + Val(My_Number.Item(x)) Next x End If Big_sum = Big_sum + My_sum ws.Cells(m, k) = My_sum My_sum = 0 m = m + 1 Next i End With ws.Cells(m, k) = Big_sum With ws.Cells(2, k).Resize(m - 1) .HorizontalAlignment = 3 .VerticalAlignment = 2 .Borders.LineStyle = 1 .Font.Bold = True End With Set rgx = Nothing: Set ws = Nothing Set My_Number = Nothing End Sub الملف مرفق ahmed_atoon.xlsm

تم ادراج العضو احمد حبيبه على القائمة السوداء عندي (لا مساعدة من جهتي) احر زيارة له قبل ساعة دون حتى ابداء الرأي بالاجابة على سؤاله

1-ليس من الضرورة رفع ملف يجتوي على اكثر من 1500 صف لان الماكرو الذي يعمل على صف واحد بستطيع العمل على الوف الصفوف 2- تم اختصار الملف الى حوالي 80 صف لمتابعة عمل الماكرو 3-الكود Option Explicit Dim sh As Worksheet Dim New_sh As Worksheet Dim lr%, Cont#, i%, x%, k% Dim SectionName As Range Const How_Many = 20 '+++++++++++++++++++++++++++++++ Sub Del_sheets() Application.DisplayAlerts = False For Each sh In Sheets If sh.Name Like "Section*" Then sh.Delete End If Next Main.Select Application.DisplayAlerts = True End Sub '++++++++++++++++++++++++++++++ Sub insert_Sheets() Del_sheets Set SectionName = Main.Range("D3:K3") lr = Main.Cells(Rows.Count, 3).End(3).Row Cont = (lr - 1) / How_Many If Int(Cont) <> Cont Then Cont = Cont + 1 End If Cont = Int(Cont) For i = 1 To Cont Sheets.Add(, Sheets(Sheets.Count)).Name = "Section_" & k * How_Many + 1 k = k + 1 SectionName.Copy With ActiveSheet.Range("D3") .PasteSpecial (xlPasteAll) .PasteSpecial (8) End With Next Application.CutCopyMode = False Main.Select End Sub '++++++++++++++++++++++++++++++++++++ Sub fil_data() Application.ScreenUpdating = False insert_Sheets x = 4 For Each New_sh In Sheets If New_sh.Name Like "Section*" Then Main.Range("D" & x).Resize(How_Many, 9).Copy New_sh.Range("D4").PasteSpecial (xlPasteAll) New_sh.Range("D4").PasteSpecial (8) x = x + How_Many End If Next Application.ScreenUpdating = True Main.Select End Sub 4-الملف مرفق Taksim_Ahmad.xlsm

بعد اذن الاستاذ وجيه لا استطيع الا أن أعطي ملاحظات لماذا لا نستغني عن الحلقة التكرارية (J) الثانية ؟؟ لأن الحلقات التكرارية ترهق البرنامج اذا كانت البيانات كبيرة و ذلك باعتماد هذا الكود Sub aa() Dim ws As Worksheet: Set ws = Sheets("Sheet1") Dim sh As Worksheet: Set sh = Sheets("Sheet2") sh.Range("a7:e55") = "" k = 7 lr = ws.Range("a" & Rows.Count).End(xlUp).Row For i = 7 To lr If ws.Range("b2") = ws.Range("c" & i) Then sh.Cells(k, 1).Resize(, 5).Value = _ ws.Range("A" & i).Resize(, 5).Value k = k + 1 End If Next sh.Activate End Sub

ممكن اوي Option Explicit Dim Ro%, i%, J%, x%, y% Dim Rg As Range, Cel As Range '+++++++++++++++++++ Sub No_merge() If ActiveSheet.Name <> "Salim" Then GoTo Fin With Range("A1").CurrentRegion For Each Cel In .Cells If Cel.MergeCells Then x = Cel.MergeArea.Rows.Count y = Cel.MergeArea.Columns.Count Cel.UnMerge Cel.Resize(x, y) = Cel.Cells(1, 1).Value End If Next .Borders.LineStyle = 1 End With Fin: End Sub '+++++++++++++++++++++++++++++++ Sub Merge_Please() If ActiveSheet.Name <> "Salim" Then GoTo Fin Application.DisplayAlerts = False x = Range("A1").CurrentRegion.Rows.Count y = Range("A1").CurrentRegion.Columns.Count For J = 1 To x For i = 1 To y If Cells(J, i) = Cells(J, i + 1) And Cells(J, i) <> "" _ And Cells(J, i + 1) <> "" Then Range(Cells(J, i), Cells(J, i + 1)).Merge End If Next Next Fin: Application.DisplayAlerts = True End Sub الملف مرفق bachiri_MERGE_Unmerge.xlsm

تفضل يا صديقي مجرد ان تدخل كود موجود مسبقاُ (من خلال الزر اضافة موظف) تحصل على رسالة خطأ moh_Unique_Code.xlsm

استبدل ما موجود بالمربع الأحمر بالكود الذي رفعته لك

(الكود يلغى الغاء دمج الخليه التى تقف عليها) اعرف هذا و لكن فيل الدمج مثلا كانت الخلية B10 و C10 تساويان "رياضيات" بعد الغاء الدمح الخلية B10 و حدها "رياضيات"

الكود لا يعطي الا أول حلية من ما كان مدمجاً

كود لأرجاع كل شيء كما كان Option Explicit Sub UNMERG() Dim x%, y%, Cel As Range With Range("A1").CurrentRegion For Each Cel In .Cells x = Cel.MergeArea.Rows.Count y = Cel.MergeArea.Columns.Count Cel.UnMerge Cel.Resize(x, y) = Cel.Cells(1, 1).Value Next .Borders.LineStyle = 1 End With End Sub

رائع استاذ وجيه باقي كود لأرجاع كل شيء كما كان بعد اذنك بلاش الـــ Select دي التي لا فائدة منها Sub aa() Application.DisplayAlerts = False Dim i, J As Integer For J = 1 To 16 For i = 2 To 7 If Cells(J, i) = Cells(J, i + 1) And Cells(J, i) <> "" _ And Cells(J, i + 1) <> "" Then Range(Cells(J, i), Cells(J, i + 1)).Merge End If Next Next Application.DisplayAlerts = True End Sub

1- اي نعديلات على الجدول يجب ادراجها في النطاق AA1:AG16 لأن الماكرو يأخذ البيانات من هناك بالنسبة للـــ UNMERGE جرب هذا الماكرو (الصفحة SALIM من هذا الملف ) Option Explicit Sub Mreg_equal_cells() Dim Ro%, i%, k%, t%, n%, ky Dim d As Object Dim Rg As Range Set d = CreateObject("Scripting.Dictionary") Ro = Cells(Rows.Count, 1).End(3).Row For t = 2 To 7 k = 1 Do Until k > Ro i = k: n = 1 Do Until Cells(i, t) <> Cells(i + 1, t) n = n + 1 i = i + 1 Loop Set Rg = Cells(k, t).Resize(n) d(Rg.Address) = "" k = k + n Loop Application.DisplayAlerts = False For Each ky In d.keys Range(ky).Merge Next Application.DisplayAlerts = True d.RemoveAll Next Application.DisplayAlerts = True End Sub '+++++++++++++++++++ Sub No_merge() Range("AA1:AG16").Copy Range("A1") End Sub الملف مرفق الصفحة SALIM bachiri401_MERGE.xlsm

الكود من أجل هذا الشيء Private Sub CommandButton1_Click() 'add Employ Set My_sh = Sheets("sheet1") RO = My_sh.Cells(Rows.Count, 1).End(3).Row + 1 Set Sarch_rg = My_sh.Range("A1:A" & RO) Set Found_rg = Sarch_rg.Find(txtcode.Text, lookat:=1) If Not Found_rg Is Nothing Then MsgBox "This Code is allready Exists" & Chr(10) & _ "In thee cell: " & Found_rg.Address(0, 0), 64 Exit Sub Else With My_sh.Cells(RO, 1) .Value = Me.txtcode.Value .Offset(, 1) = Me.txtname.Value .Offset(, 2) = Me.txtjop.Value .Offset(, 3) = Me.txtadress.Value .Offset(, 4) = Me.txtid.Value End With End If Me.ListBox1.RowSource = "a2:e" & RO End Sub

1-لا حاجة لنكرار المتغيرات في كل كود من أكواد اليوزر يكفي ان تعلنها مرة واحدة في البداية 2- تم التعديل على الأكواد (الغاء الحلقات التكرارية التي ترهق البرنامج في حال كانت البيانات كثيرة) والاستيعاض عنها بدالة Find التي تضع يدها على الصف المناسب رأساً بدون التفتيش في كل الصفوف 3- ما الحاجة الى ادخال 1000 صف في ال ـ TextBox النطاق A2:E1000 من خلال Form Initialize ونحن بحاجة الى القليل منها (البيانات حتى اخر صف غير فارغ) 4- الاكواد بعد التعديل Option Explicit Dim RO%, t% Dim My_sh As Worksheet Dim Sarch_rg As Range Dim Found_rg As Range '++++++++++++++++++++++++++++++++++++++++++++++++++++ Private Sub CommandButton1_Click() 'add Employ Set My_sh = Sheets("sheet1") RO = ws.Cells(Rows.Count, 1).End(3).Row + 1 With My_sh.Cells(RO, 1) .Value = Me.txtcode.Value .Offset(, 1) = Me.txtname.Value .Offset(, 2) = Me.txtjop.Value .Offset(, 3) = Me.txtadress.Value .Offset(, 4) = Me.txtid.Value End With Me.ListBox1.RowSource = "a2:e" & RO End Sub '++++++++++++++++++++++++++++++++++++++++++++++ Private Sub CommandButton2_Click() 'search Set My_sh = Sheets("sheet1") RO = My_sh.Cells(Rows.Count, 1).End(3).Row Set Sarch_rg = My_sh.Range("A1:A" & RO) Set Found_rg = Sarch_rg.Find(txtcode.Text, lookat:=1) If Found_rg Is Nothing Then MsgBox "Not Fount" Exit Sub Else t = Found_rg.Row With My_sh.Cells(t, 1) Me.txtcode.Text = .Value Me.txtname.Text = .Offset(, 1) Me.txtjop.Text = .Offset(, 2) Me.txtadress.Text = .Offset(, 3) Me.txtid.Text = .Offset(, 3) End With End If End Sub '+++++++++++++++++++++++++++++++++++++ Private Sub CommandButton3_Click() 'Remove Set My_sh = Sheets("sheet1") RO = My_sh.Cells(Rows.Count, 1).End(3).Row Set Sarch_rg = My_sh.Range("A1:A" & RO) Set Found_rg = Sarch_rg.Find(txtcode.Text, lookat:=1) If Found_rg Is Nothing Then MsgBox "Not Fount" Exit Sub Else t = Found_rg.Row My_sh.Cells(t, 1).Resize(, 5).Delete End If End Sub '++++++++++++++++++++++++++++++++++++++ Private Sub CommandButton4_Click() Dim txt For Each txt In Frame2.Controls If TypeOf txt Is msforms.TextBox Then txt.Text = "" End If Next txt End Sub '+++++++++++++++++++++++++++++++++ Private Sub CommandButton5_Click() Set My_sh = Sheets("sheet1") Application.Dialogs(xlDialogPrinterSetup).Show My_sh.PrintOut copies:=1 End Sub '+++++++++++++++++++++++++++++++++++ Private Sub CommandButton6_Click() Unload Me End Sub '++++++++++++++++++++++++++++++++ Private Sub CommandButton7_Click() 'Update Set My_sh = Sheets("sheet1") RO = Cells(Rows.Count, 1).End(xlUp).Row Set Sarch_rg = My_sh.Range("A1:A" & RO) Set Found_rg = Sarch_rg.Find(txtcode.Text, lookat:=1) If Found_rg Is Nothing Then MsgBox "Not Fount" Exit Sub Else t = Found_rg.Row With My_sh.Cells(t, 1) .Offset(, 1) = Me.txtname.Text .Offset(, 2) = Me.txtjop.Text .Offset(, 3) = Me.txtadress.Text .Offset(, 4) = Me.txtid.Text End With Me.ListBox1.RowSource = "a2:e" & RO MsgBox "Data Edite Succesufly", vbInformation, "alarm" End If End Sub '+++++++++++++++++++++++++++++++++++++++++++++ Private Sub UserForm_Initialize() Set My_sh = Sheets("sheet1") RO = My_sh.Cells(Rows.Count, 1).End(3).Row Me.ListBox1.ColumnCount = 5 Me.ListBox1.RowSource = "a2:e" & RO End Sub الملف مرفق moh_Form_322.xlsm

أكثر من ذلك تم تطوير الكود بحيث تظهر النتائج في عامود واحد مع ترقيمها Option Explicit Dim F As Worksheet, M As Worksheet Dim L_M%, L_F%, K%, t%, xx%, A% Dim x As Boolean, y As Boolean, z As Boolean Dim D1 As Date, D2 As Date Dim Obj As Object '++++++++++++++++++++++++++++++++++++ Sub fin_Please(Rg1 As Range) D1 = Application.Min(Rg1.Resize(, 2)) D2 = Application.Max(Rg1.Resize(, 2)) For K = 2 To L_M x = IsDate(M.Cells(K, 1)) y = M.Cells(K, 1) >= D1 z = M.Cells(K, 1) <= D2 If x * y * z <> 0 Then Obj(M.Cells(K, 3).Value) = vbNullString End If Next K If Obj.Count Then Rem Typing The Results in the Sheet xx = F.Cells(Rows.Count, 1).End(3).Row + 1 With F.Range("A" & xx) .Value = "From " & F.Range("D" & A) _ & " To " & F.Range("E" & A) .Interior.ColorIndex = 40 With .Offset(1).Resize(Obj.Count) .Value = Application.Transpose(Obj.keys) .Interior.ColorIndex = 35 .Offset(, 1).Value = _ Evaluate("Row(1:" & Obj.Count & ")") .Offset(, 1).Interior.ColorIndex = 19 End With End With Rem End Of Typing The Results in the Sheet End If End Sub '+++++++++++++++++++++++++++++++++++++++ Sub test() Rem Created By Salim Hasbaya On Nov. 17 2020 Application.ScreenUpdating = False Dim First_Col, Second_col%, Mycol% Dim Cel As Range, Mesg$ Set F = Sheets("Final") Set M = Sheets("Main") Set Obj = CreateObject("Scripting.Dictionary") Rem Clear Old Data t = F.Range("A2").CurrentRegion.Rows.Count If t > 1 Then F.Range("A2").CurrentRegion. _ Offset(1).Resize(t - 1).Clear End If Rem End of Clear Old Data L_F = F.Cells(Rows.Count, 4).End(3).Row L_M = M.Cells(Rows.Count, 1).End(3).Row Rem For Control the dates==================== First_Col = L_F Second_col = F.Cells(Rows.Count, 5).End(3).Row If First_Col < 2 Or Second_col < 2 Then Application.ScreenUpdating = True Exit Sub End If Mycol = Application.Max(First_Col, Second_col) For Each Cel In F.Range("D2:E" & Mycol) If Not IsDate(Cel) Then Mesg = Mesg & Cel.Address & Chr(10) End If Next If Mesg <> "" Then MsgBox "Check Up This Cells Please:" & Chr(10) _ & Mesg & Chr(10) & _ "They Must Be A Date" Application.ScreenUpdating = True Exit Sub End If Rem End of For Control the dates ================== Rem Looping Throught the dates in Column D And E For A = 2 To L_F fin_Please (Sheets("Final").Range("D" & A)) Obj.RemoveAll Next Rem end of Looping Throught the dates in Column D And E Rem Format The Results t = F.Range("A2").CurrentRegion.Rows.Count If t > 1 Then With F.Range("A2").CurrentRegion. _ Offset(1).Resize(t - 1).SpecialCells(2, 23) .Borders.LineStyle = 1 .InsertIndent 1 .Font.Size = 16: .Font.Bold = True End With End If Rem End Of Format The Results Application.ScreenUpdating = True End Sub الملف من جديد Hani_Exact_1.xlsm

تم معالجة الأمر بعد تطوير الكود ليطعي رسالة خطأ اذا كانت احد الخلايا في العامودين D و E لا تصلح كتاريخ (أو فارغة) Hani_Exact.xlsm

انت هنا تجدد: اول 3 صفوف للتاريخ من 1/7/2020 الى 31/7/2020 وما ادراك ان العدد سيكون 3 شركات؟؟؟ ومن الصف 5 الى الصف 10 للتاريخ من 1/8/2020 الى 31/8/2020 وما ادراك ان العدد سيكون 6 شركات؟؟؟ ربما ينفع احد هذين الملفين (الرجاء ابلاغي ايهما تريد لا تقل الاول او الثّاني اريد تسمية الملف) Company_Repprt_ExPlicit.xlsm Hani.xlsm

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

كان يجب الأخذ بنصيحة الاستاذ مهند (ولكن حيث ان السؤال محدد ولا يستهلك وقتاً لارفاق مثال نموذج) جرب هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("E4:E5")) Is Nothing _ And Target.Count = 1 Then With Target Select Case True Case .Row = 4 .Offset(1) = vbNullString Case .Row = 5 .Offset(-1) = vbNullString End Select End With End If Application.EnableEvents = True End Sub الملف مرفق On_OFF.xlsm

يجب حفظ الملف بصيغة xlsm لا بصيغة xlsx كما هو موضح بالصورة ملف احر مرفق مع معادلة( ايضاً يجب حفظه الملف بصيغة xlsm) Taswiyat_formula.xlsm

بارك الله بك اخي علي ولاثراء الموضوع هذا الكود (بعمل في حال وجود فواصل عشرية "." ولا يتعاطى مع ما يوجد بين الارفام / +/ - /نصوص الخ....) Option Explicit Sub Extract_Number() Dim rgx As Object Dim My_Number As Object Dim ws As Worksheet Dim i%, x%, Ro%, My_Sum# Set rgx = CreateObject("VBScript.RegExp") Set ws = Worksheets("Sheet1") Ro = ws.Cells(Rows.Count, "F").End(3).Row ws.Range("D4").Resize(15, 2).ClearContents With rgx .Global = True: .Pattern = "(\d+\.?\d+)" For i = 4 To Ro My_Sum = 0 If .test(ws.Cells(i, "F")) Then Set My_Number = .Execute(ws.Cells(i, "F")) ws.Cells(i, 5) = My_Number.Count For x = 0 To My_Number.Count - 1 My_Sum = My_Sum + Val(My_Number.Item(x)) Next x End If Cells(i, 4) = My_Sum Next i End With End Sub الملف مرفق Taswiyat.xlsm

ماذا تريد من الجدول الفارغ الذي رفعته رجاء املأه بيانات والتنائج التي تتوقعها (يمكن يدوياً ريثما نجد ما تريد ان يقوم به البرنامج اوتوماتيكياً)

1-لقد تم تنبيهك الى وجوب رفع ملف فيه الشرح الكافي 2- حبث انك عضو جدبد في المنتدى فأهلاً وسهلاً بك 3-لكن في المرة المقبلة سوف تحذف اي مشاركة بدون ملف مرفق جرب هذا الكود Option Explicit Rem code for Extact Number_From_Text Rem Created By Salim Hasbaya On 14/11/2020 Sub Extract_Number_From_Text() Dim rgx As Object Dim My_Number As Object Dim ws As Worksheet Dim i%, m%, k%, x%, Ro% Set rgx = CreateObject("VBScript.RegExp") Set ws = Worksheets("Salim") Ro = ws.Cells(Rows.Count, 1).End(3).Row With ws.Range("C1").Resize(Ro, 20) .ClearContents .Interior.ColorIndex = xlNone End With m = 1: k = 4 With rgx .Global = True: .Pattern = "(\d+)" For i = 1 To Ro If .test(ws.Cells(i, 1)) Then Set My_Number = .Execute(ws.Cells(i, 1)) ws.Cells(m, 3) = My_Number.Count & " Numbers" ws.Cells(m, 3).Interior.ColorIndex = 6 For x = 0 To My_Number.Count - 1 ws.Cells(m, k).Offset(, x) = Val(My_Number.Item(x)) Next x End If m = m + 1 Next i End With End Sub الملف مرفق فقط اضغط الزر Run Please Extract_Number_From_Text.xlsm

جرب هذا الملف Option Explicit Sub test() Dim ar Dim i%, Formul$, K ar = Array("+", "-", "'", "?", """""", ",", "/", "@") For K = 1 To Range("a1").CurrentRegion.Rows.Count Formul = Trim(Replace(Range("A" & K), ar(0), ",")) For i = 1 To UBound(ar) Formul = Replace(Formul, ar(i), ",") Next Cells(K, 3) = Evaluate("sum(" & Formul & ")") Formul = "" Next End Sub shoaip.xlsm