سليم حاصبيا

اذا اردت ان تكون الاسماء في خلية واحدة (صفحة Salim من هذا الملف) هذا الكود Option Explicit Sub max_min() Dim mY_rg As Range Dim last_row%, i%, J% Dim M%: M = 12 last_row = Cells(Rows.Count, 1).End(3).Row Dim st_max$, st_min$ Range("l2").CurrentRegion.Offset(1).ClearContents For i = 3 To last_row For J = 2 To 5 If Cells(i, J) = _ Application.Min(Cells(i, 2).Resize(, 4)) Then st_min = st_min & Cells(2, J) & "," ElseIf Cells(i, J) = _ Application.Max(Cells(i, 2).Resize(, 4)) Then st_max = st_max & Cells(2, J) & "," End If Next Cells(i, M) = Mid(st_min, 1, Len(st_min) - 1) Cells(i, M + 1) = Mid(st_max, 1, Len(st_max) - 1) st_min = "": st_max = "" Next End Sub الملف مرفق Tahsil_Macro.xlsm

ربما هذا ما تقصده Tahsil_1.xlsx

هذه المعادلة في G3 واسحب نزولاً =INDEX($B$2:$E$2,MATCH(MAX($B3:$E3),$B3:$E3,0)) لكن المشكلة اذا تساوى رقمان أو أكثر و كانا ( Max أو Min ) تحصل على أول اسم فقط كما في الصف الخامس او السادس من هذا الملف Tahsil.xlsx

تم معالجة الموضوع لاحظ في المرفق الورقة NoData لا تحتوي على بيانات لازمة فتجاهلها الكود كذلك الشيت المخصصات لا تحتوي على كلمة الاسم في العامود B فتجاهلها الكود امام الشيت laste_sheet فتم ادراجها Option Explicit Sub Salim_Has() Dim my_rg As Range Dim Main As Worksheet Dim Cont%: Cont = Sheets.Count If Cont = 1 Then Exit Sub Set Main = Sheets("الخلاصة") On Error Resume Next Main.Cells.ClearContents On Error GoTo 0 Dim NUM%: NUM = 1 Dim i%, x%: x = 1 Dim arr_sh() Dim const_arr(1 To 3) const_arr(1) = "رقم القائمة": const_arr(2) = "عدد أسماء القائمة" const_arr(3) = "مبلغ القائمة" For i = 1 To Cont If Sheets(i).Name = "الخلاصة" Then _ GoTo NexT_i If IsError(Application.Match("الاسم", Sheets(i).Range("B:B"), 0)) _ Then GoTo NexT_i ReDim Preserve arr_sh(1 To NUM) arr_sh(NUM) = Sheets(i).Name NUM = NUM + 1 NexT_i: Next For i = 1 To UBound(arr_sh) Main.Cells(1, x) = arr_sh(i) Main.Cells(2, x).Resize(, 3) = const_arr x = x + 4 Next get_data Erase arr_sh: Erase const_arr End Sub Rem ========================== Rem form here start a new Macro Rem========================= Sub get_data() Dim Prince_sh As Worksheet Set Prince_sh = Sheets("الخلاصة") Dim last_col%, my_st$: my_st$ = "قائمة رقم " Dim i%, last_row%, m%: m = 4 Dim k%, XX%, t%: t = 1 Dim target_sh As Worksheet Dim temp As Range last_col = Prince_sh.Cells(1, Columns.Count).End(1).Column For i = 1 To last_col Step 4 Set target_sh = Sheets(Prince_sh.Cells(1, i) & "") last_row = target_sh.Cells(Rows.Count, 1).End(3).Row For k = 2 To last_row If target_sh.Cells(k, 2) <> "الاسم" And target_sh.Cells(k, 2) <> vbNullString Then If temp Is Nothing Then Set temp = target_sh.Cells(k, 2) Else Set temp = Union(target_sh.Cells(k, 2), temp) End If End If Next If temp Is Nothing Then GoTo My_Next For XX = temp.Areas.Count To 1 Step -1 Prince_sh.Cells(m, i) = my_st$ & t Prince_sh.Cells(m, i + 1) = Application.CountA(temp.Areas(XX)) Prince_sh.Cells(m, i + 2) = Application.Sum(temp.Areas(XX).Offset(, 9)) m = m + 1: t = t + 1 Next My_Next: Set temp = Nothing: m = 4: t = 1 Next End Sub My_Last_File.xlsm

الكود لا يتأئر باسماء الشيتات لأنه يدرجها اوتوماتيكياً في الصف الأول فقط يجب ان تكون الصفحة "خلاصة "هي الأولى واذا وجدت شيت لا تحتوي على بيانات(في الأعمدة 1و2و3) يتم تجاهلها مهم جداً وجود كلمة "الاسم" في العامود الثاني من كل شيت

من العامود B الى العامود K هناك 10 أعمدة (تنقص منها 1 ) فتصبح 9 في هذا السطر من الكود Prince_sh.Cells(m, i + 2) = Application.Sum(temp.Areas(XX).Offset(, 1)) تستبدل الرقم 1 بالرقم 9 ليصبح بهذا الشكل Prince_sh.Cells(m, i + 2) = Application.Sum(temp.Areas(XX).Offset(, 9))

من الصعب جداً تشغيل معادلات لمثل هذه الــ DATA لكن بواسطة الــ VBA يمكن عمل أي شيء الملف المرفق ديناميكي تستطيع ان تضع قدر ما تشاء من الأقسام والقوائم الكود Option Explicit Sub Salim_Has() Dim my_rg As Range Dim Main As Worksheet Set Main = Sheets("الخلاصة") Main.Cells.ClearContents Dim i%, x%: x = 1 Main.Rows("1:2").ClearContents Dim const_arr(1 To 3) const_arr(1) = "رقم القائمة": const_arr(2) = "عدد أسماء القائمة" const_arr(3) = "مبلغ القائمة" Dim arr_sh(1 To 3) For i = 1 To Sheets.Count - 1 arr_sh(i) = Sheets(i + 1).Name Next For i = 1 To UBound(arr_sh) Main.Cells(1, x) = arr_sh(i) Main.Cells(2, x).Resize(, 3) = const_arr x = x + 4 Next get_data End Sub Rem ========================== Rem form here start a new Macro Rem========================= Sub get_data() Dim Prince_sh As Worksheet Set Prince_sh = Sheets("الخلاصة") Dim last_col%, my_st$: my_st$ = "قائمة رقم " Dim i%, last_row%, m%: m = 4 Dim k%, XX%, t%: t = 1 Dim target_sh As Worksheet Dim temp As Range last_col = Prince_sh.Cells(1, Columns.Count).End(1).Column For i = 1 To last_col Step 4 Set target_sh = Sheets(Prince_sh.Cells(1, i) & "") last_row = target_sh.Cells(Rows.Count, 1).End(3).Row For k = 2 To last_row If target_sh.Cells(k, 2) <> "الاسم" And target_sh.Cells(k, 2) <> vbNullString Then If temp Is Nothing Then Set temp = target_sh.Cells(k, 2) Else Set temp = Union(target_sh.Cells(k, 2), temp) End If End If Next If temp Is Nothing Then GoTo My_Next For XX = temp.Areas.Count To 1 Step -1 Prince_sh.Cells(m, i) = my_st$ & t Prince_sh.Cells(m, i + 1) = Application.CountA(temp.Areas(XX)) Prince_sh.Cells(m, i + 2) = Application.Sum(temp.Areas(XX).Offset(, 1)) m = m + 1: t = t + 1 Next My_Next: Set temp = Nothing: m = 4: t = 1 Next End Sub الملف مرفق Full_File.xlsm

تم معالجة الامر (بواسطة Auto filter ) مع تعبئة اوتوماتيكية للــ Combo Box دون تكرار Copy_filtred_rows_without_Hedears.xlsm

كود رائع استاذ مصطفى لكن يمكن تخفيف الحلقات التكرارية 6 مرات في كل صف (بازالة الحلقة التكرارية j ) التي لا لزوم لها بذلك ننقل البيانات صفاً بعد صف وليس خلية بعد اخرى في كل عامود (تخيل عندنا 500 عامود الحلقة اللازمة لــ j من 1 الى 500) Private Sub Worksheet_Change(ByVal Target As Range) With Application .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With If Target.Address = "$B$4" Then ورقة2.Range("A7:F55") = "" k = 7 LR = Sheets(1).Range("C" & Rows.Count).End(xlUp).Row For i = 24 To LR If ورقة2.Range("B4") = ورقة1.Range("c" & i) Then ورقة2.Cells(k, 1).Resize(, 6).Value = _ ورقة1.Cells(i, 4).Resize(, 6).Value k = k + 1 End If Next End If With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True .EnableEvents = True End With End Sub

تعديل على الكود ليتناسب مح المطلوب Option Explicit Sub Salim_Has() Dim my_rg As Range Dim i%, last_row%, m%: m = 2 Dim my_st$ my_st$ = "قائمة رقم " last_row = Quawaem.Cells(Rows.Count, 1).End(3).Row Khoulasa.Range("a1").CurrentRegion. _ Offset(1).ClearContents For i = 3 To last_row If Quawaem.Range("b" & i) <> "" And _ Quawaem.Range("b" & i) <> "الاسم" Then If my_rg Is Nothing Then Set my_rg = Quawaem.Range("B" & i) Else Set my_rg = Union(Quawaem.Range("B" & i), my_rg) End If End If Next For i = my_rg.Areas.Count To 1 Step -1 With Khoulasa.Cells(m, 1) .Value = my_st$ & m - 1 .Offset(, 1) = Application.CountA(my_rg.Areas(i)) .Offset(, 2) = Application.Sum(my_rg.Areas(i).Offset(, 1)) End With m = m + 1 Next Set my_rg = Nothing End Sub الملف من جديد Quawaem_count_new.xlsm

ربما ينفع هذا الكود Sub Salim_Has() Dim my_rg As Range Dim i%, last_row%, m%: m = 2 Dim my_st$ my_st$ = "قائمة رقم " last_row = Quawaem.Cells(Rows.Count, 1).End(3).Row Khoulasa.Range("a1").CurrentRegion. _ Offset(1).ClearContents For i = 3 To last_row If Quawaem.Range("b" & i) <> "" And _ Quawaem.Range("b" & i) <> "الاسم" Then If my_rg Is Nothing Then Set my_rg = Quawaem.Range("B" & i) Else Set my_rg = Union(Quawaem.Range("B" & i), my_rg) End If End If Next For i = my_rg.Areas.Count To 1 Step -1 Khoulasa.Cells(m, 2) = _ Application.CountA(my_rg.Areas(i)) Khoulasa.Cells(m, 1) = my_st$ & m - 1 m = m + 1 Next Set my_rg = Nothing End Sub الملف مرفق Quawaem_count_new.xlsm

السؤال غير مغهوم من فضلك قم بكتابة النتائج المتوقعة يدوياً وارفع الملف فيها

لعدم السماح بكتابة مسافات زائدة في الخلية (مثلاً A1) يسمح فقط بمسافة واحدة بين كل كلمتين 1- اضغط Alt +D+L (للدخول الى Data validation) بعد تحديد الخلية الهدف طبعاً (A1) 2-من خلال Custom اكتب المعادلة التالية: =LEN(A1)-LEN(TRIM(A1))=0

مع عدم ارسال ملف للمعالجة ربما هذا النموذج يفي بالغرض الكود Option Explicit Sub My_sum() Dim Dic As Object Dim i%, k, Itm, Laste_Row% Laste_Row = Cells(Rows.Count, 1).End(3).Row If Laste_Row < 5 Then Exit Sub Range("b1:Z2").ClearContents Set Dic = CreateObject("Scripting.Dictionary") With Dic For i = 5 To Laste_Row If Range("a" & i) <> vbNullString Then k = Range("a" & i) Itm = Application.Sum(Range("b" & i).Resize(, 5)) If Not .Exists(k) Then .Add k, Itm Else Select Case Range("I4") Case "ALL": Dic(k) = Dic(k) + Itm Case Else: Dic(k) = Itm End Select End If End If Next Range("B1").Resize(1, .Count) = .keys Range("B2").Resize(1, .Count) = .Items End With '=============== End Sub الملف مرفق Sum_by_diuctionary.xlsm

مثال عما تريد بطريقتين 1- معادلة عادية صفحة Simple 2 بواسطة الكود صفحة Salim الكود المستعمل Option Explicit Function Inter_Sum(My_Val, Pat As String) Rem ====>> Created by Salim Hasbaya On 1/7/2019 Dim Obj As Object Set Obj = CreateObject("VBScript.regexp") Dim My_Match Dim t% With Obj .Global = True .Pattern = Pat If .Test(My_Val) Then For Each My_Match In .Execute(My_Val) t = t + IIf(IsNumeric(My_Match), My_Match, 0) Next End If End With Inter_Sum = t End Function الملف مرفق Creezy_sum_VBA.xlsm

تم سحب القيم صفر من المعادلة test_sans_Zeros.xlsx

لا ا‘لم اذا كان هذا المطلوب بالضبط Text_Me.xlsx

للعمل بشكل جيد يجب 1-ازالة الخلايا المدمجة (عدو الاكواد) 2-ترتيب الييانات كما في الملف المرفق (صفحة Source) الكود اللازم Option Explicit Sub give_data_by_Order() Rem =====>> Created By Salim Hasbaya On 30/6/2019 Dim i#, r#, Fix_ro, t# Dim search_rg As Range Dim rg_to_copy As Range Dim m#: m = 2 Dim col As New Collection Dim last_row# last_row = Source_sh.Cells(Rows.Count, 1).End(3).Row For i = 1 To last_row On Error Resume Next If Source_sh.Range("e" & i) <> "" Then col.Add Source_sh.Range("e" & i).Value, Source_sh.Range("e" & i).Value End If Next On Error GoTo 0 Target_sh.Range("A:E").ClearContents For i = 1 To col.Count Set search_rg = Source_sh.Range("E:E").Find(col(i), after:=Source_sh.Cells(Rows.Count, "E")) r = search_rg.Row: Fix_ro = r If Not search_rg Is Nothing Then '=================== Do Set rg_to_copy = _ Source_sh.Range("a" & r + 1, Source_sh.Range("a" & r + 2).End(4).Resize(, 4)) Target_sh.Cells(m, 5) = search_rg.Value & " (" & t + 1 & ")" t = t + 1 rg_to_copy.Copy _ Target_sh.Cells(m, 1) m = m + rg_to_copy.Rows.Count + 1 Set search_rg = Source_sh.Range("E:E").FindNext(search_rg) r = search_rg.Row If r = Fix_ro Then Exit Do Loop '======================= End If t = 0 Next End Sub الملف مرفق Copy_Data_Please.xlsm

جرب هذا الملف Mou3id.xlsx

تم التعديل على الماكرو لينناسب مع المطلوب Sub Salim_Macro_new() Rem Created On 31/5/2019 By Salim Hasbaya 'Modefied on 29/6/2019 Application.ScreenUpdating = False If Application.CountA(Sheets("Main").Range("a2:c2")) < 3 Then GoTo Leave_Me_Olone End If Dim New_ro% Dim t%: t = Sheets(Sheets.Count).Index Dim target_sh As Worksheet Dim M_sh As Worksheet Dim last_ro% laste_ro = Sheets(t).Cells(Rows.Count, 1).End(3).Row Select Case laste_ro Case 11 Set target_sh = Sheets.Add(after:=Sheets(t)) With ActiveSheet .Name = "Salim" & t - 1 Sheets("Main").Range("a1:c2").Copy '===================== With .Cells(1, 1) .PasteSpecial (xlPasteAll) .PasteSpecial (8) End With '======================== End With Case Else Set target_sh = Sheets(Sheets.Count) With target_sh New_ro = .Cells(Rows.Count, 1).End(3).Row + 1 '=========================== Sheets("Main").Range("a2:c2").Copy With .Cells(New_ro, 1) .PasteSpecial (xlPasteAll) .PasteSpecial (8) End With End With End Select '============================== Sheets("Main").Range("a2:c2").ClearContents Leave_Me_Olone: Sheets("Main").Select Application.ScreenUpdating = True End Sub الملف مرفق 29_6_2019_salim.xlsm

السؤال هنا هل ان الحصة كل موظف مستقلة عن قيمة الدخول او لا مثلاً اذا كانت حصة علي 500 اذا كان الدخول 1000 هل هي نفسها (500) اذا كان الدخول 5000 اذا كان ذلك صحيحاً هذه المعادلة في الخلية J3 وتسحب نزولاً =IF(COUNTIF($E$8:$E$47,$I3)=0,"",COUNTIF($E$8:$E$47,$I3)*(VLOOKUP($I3,{"علي",500;"إبراهيم",1000;"محمد",750;"موسى",250;0,0;0,0;0,0;0,0;0,0;0,0;0,0;0,0;0,0;0,0;0,0;0,0;0,0;0,0},2,0))) اذا لم تعمل المعادلة استبدل الفاصلة ", " بفاصلة منقوطة";" (خارج الأقواس المعكوفة { } ) لتبدو المعادلة هكذا =IF(COUNTIF($E$8:$E$47;$I3)=0;"";COUNTIF($E$8:$E$47;$I3)*(VLOOKUP($I3;{"علي",500;"إبراهيم",1000;"محمد",750;"موسى",250;0,0;0,0;0,0;0,0;0,0;0,0;0,0;0,0;0,0;0,0;0,0;0,0;0,0;0,0};2;0)))

جرب هذا الكود في المثال المرفق Option Explicit Sub Macro_to_copy() Sheets("Sheet1").Range("A1:I5").Copy With Sheets("Sheet2").Range("a1") .PasteSpecial (13) .PasteSpecial (3) End With Application.CutCopyMode = False End Sub Copy_For_Me.xlsm

مشكور جداً اخي علي على هذا الكود لكن الموضوع ليس تحديداً تقسيم الاسم (يوجد اشياء كثيرة بهذا الشأن) بقدر ما هو قدرة تطويع REGULAR EXPRESSION التي تستعمل كما هو معروف مصطلحات مثل (w+.\d \ s الخ..... ) لتعمل مع اللغة العربية

من المعروف اصطلاحات REGULAR EXPRESSION تستخدم للغة الانكليزية لكن يمكن تطويعها للعمل باللغة العربية\ اليكم هذا المثال Option Explicit Sub Separate_Arabic_Word_Using_regex() Dim obj As Object Dim i%, m%, k% Dim Matches m = 2: k = 4 Set obj = CreateObject("vbscript.regexp") With obj .Pattern = "[\u0621-\u064A]+" .Global = True End With Range("A4").CurrentRegion.Offset(, 1).ClearContents Do Until Range("a" & k) = vbNullString Set Matches = obj.Execute(Range("a" & k)) If Matches.Count > 0 Then For i = 0 To Matches.Count - 1 Cells(k, m) = Matches(i) m = m + 1 Next End If m = 2 k = k + 1 Loop End Sub '[\u0621-\u064A]+ pattern (for arabic language) '.Pattern = "\b\w+\b" pattern (for Eng language) للايضاح الملف مرفق SEPARETE_NAMES_BY_REGEX.xlsm

بعد اذن الاساتذة كود على السريع Private Sub TextBox1_Change() Application.EnableEvents = False If TextBox1.TextLength > 12 Then MsgBox "Too long Expression" TextBox1 = vbNullString End If Application.EnableEvents = True End Sub