محمد هشام.

Sub RemoveChars() Dim lr&, Cel As Range, A As String, r As Range lr = Cells(Rows.Count, "b").End(xlUp).Row Application.ScreenUpdating = False Set r = Range("b2:b" & lr) For Each Cel In r A = Replace(Cel.Value, ",", " ") Cel.Value = A Next Cel Application.ScreenUpdating = True End Sub

المفروض انك تعلم ما يفعله الكود هو في الاصل لا يقوم بالتفريغ وانما يقوم بنسخ بيانات الاسم الموجود في الخلية F1 وبما ان الاسم مكرر اكثر من مرة مع وجود فراغات في الاعمدة المقابلة يقوم بنسخ لك قيمة فارغة لان تركيبة الكود هي جلب جميع بيانات الاسم حاول وضع تواريخ امام اسم محمد مثلا وتجربة الكود لتتضح لديك الفكرة بعد تنفيد الكود

ضع الكود التالي في حدث ورقة DATA لجلب اسماء العملاء Private Sub Worksheet_Change(ByVal Target As Range) Set F = Sheets("DATA"): Set n = F.[G2] With Application .ScreenUpdating = False .EnableEvents = False If Target.Column = 1 Then F.Range("G2:G" & F.UsedRange.Rows.Count).ClearContents Set d = CreateObject("Scripting.Dictionary") a = Range(F.[A2], F.[A65000].End(xlUp)).Value For Each c In a d(c) = "" Next c n.Resize(d.Count, 1) = Application.Transpose(d.keys) n.Resize(d.Count, 1).Sort Key1:=n, Order1:=xlAscending Set d = Nothing End If .EnableEvents = True .ScreenUpdating = True End With End Sub مع تسمية النطاق وليكن مثلا list واخيرا قم بنسخ هدا في حدث ورقة 7 Option Compare Text Dim F(), OneRng, lr& Public Property Get Sh2() As Worksheet: Set Sh2 = Worksheets("DATA") End Property Private Sub ComboBox1_Change() Dim Cnt() Set OneRng = ActiveCell: Cnt = Application.Transpose([List]) Me.ComboBox1.List = Cnt If Me.ComboBox1.ListIndex = -1 And _ IsError(Application.Match(Me.ComboBox1, Cnt, 0)) Then Me.ComboBox1.List = Filter(Cnt, Me.ComboBox1.Text, True, vbTextCompare) Me.ComboBox1.DropDown End If OneRng.Value = Me.ComboBox1 End Sub '************************* Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim sh1 As Worksheet: Set sh1 = Worksheets("7") lr = 150 'sh1.Range("a" & sh1.Rows.Count).End(xlUp).Row Set tmp = Range("C4:C" & lr) If Not Intersect(tmp, Target) Is Nothing And Target.Count = 1 Then If Cnt <> "" Then If IsError(Application.Match(Range(Cnt), F, 0)) Then Range(Cnt) = "" F = Application.Transpose(Sh2.Range("list")) Me.ComboBox1.Height = Target.Height + 4 Me.ComboBox1.Width = Target.Width Me.ComboBox1.BackColor = RGB(204, 253, 253) Me.ComboBox1.Top = Target.Top: Me.ComboBox1.Left = Target.Left: Me.ComboBox1 = Target Me.ComboBox1.Visible = True Me.ComboBox1.Activate Cnt = Target.Address Else Me.ComboBox1.Visible = False End If End Sub '************************* Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Set OneRng = ActiveCell If KeyCode = 13 Then If IsError(Application.Match(OneRng, F, 0)) Then OneRng = "" OneRng.Offset(1).Select End If End Sub '************************* Private Sub ComboBox1_DropButtonClick() lr = Sh2.Cells(Rows.Count, 7).End(xlUp).Row ComboBox1.List = Sh2.Range("G2:G" & lr).Value End Sub '************************* Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then ComboBox1.Value = "" End If End Sub البحث باي جزء من الاسم يمكنك استخدام نفس الكود على اي ورقة بعد تعديل الاسم Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim sh1 As Worksheet: Set sh1 = Worksheets("7") <====== قائمة بحث بجزء من الاسم.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته هل هناك مانع لاستخدام الأكواد؟

ما الغرض من فك حماية جميع اوراق العمل لتقوم بافراغ الخلايا المحددة على ورقة عمل واحدة جرب هدا Sub Protect() Dim x As Worksheet Set x = ActiveSheet Application.ScreenUpdating = False x.Unprotect "bac20022002" With Selection .ClearContents End With x.Protect "bac20022002" Application.ScreenUpdating = True End Sub

اخي الكريم اظن ان الفكرة لم تتضح اليك لابد من وجود قاعدة بيانات يتم تعبئة عناصر الكومبوبوكس منها بحيث عند اختيارك للقيم المطلوبة تقوم بترحيلها للخلايا الهدف لان طريقة اشتغالك على الملف بخلايا فارغة مع شرط تتابع وترابط القوائم تتطلب طريقة خاصة انت لم تكلف نفسك حتى لتصميم نمودج يوزرفورم للاشتغال عليه بالتوفيق

ربما لم تنتبه للمشاركة السابقة زيادة ان الملف المرفق مغاير عن الملف الاول هل تقصد قاعدة البيانات هي الاعمدة الملونة بالاحمر لنفترض اننا قمنا بتحديد العناصر المختارة على عدد معين من الكومبوبوكس اين سيتم ترحيلها

بطريقة اخرى Option Compare Text Public Property Get F() As Worksheet: Set F = Worksheets("12 د بنون") End Property Public Property Get lr() As Long: lr = F.Columns("C:J").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row End Property Sub Sort_Names() 'ترتيب ابجدي Dim OneRng As Range Set OneRng = F.Range("C11:J" & lr) With OneRng .Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlNo End With End Sub '*********** Sub Sort_TOTAL() 'ترتيب تنازلي Dim OneRng As Range Set OneRng = F.Range("C11:J" & lr) With OneRng .Sort Key1:=.Columns(7), Order1:=xlDescending, Header:=xlNo End With End Sub '********* Sub Sort_TOTAL2() 'ترتيب تصاعدي Dim OneRng As Range Set OneRng = F.Range("C11:J" & lr) With OneRng .Sort Key1:=.Columns(7), Order1:=xlAscending, Header:=xlNo End With End Sub فرز Final.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته اعتقد اخي الفاضل ان انسب طريقة لدالك هي استخراج القيم التي يساوي مجموعها القيمة المدخلة في عمود مغاير لان الاعتماد على التظليل ممكن يسبب لك تداخل في النتائج المتوقعة عند تواجد نفس الرقم في اكثر من احتمال مثال لو اردنا استخراج الاعداد الخاصة ب 34 مع وجود الارقام التي قمت بدكرها في مشاركتك سنعثر على نفس الارقام مكررة في اكثر من احتمال 👇 لتتفادى هدا ممكن استخدام الدالة التالية مثال لعملية استخراج القيم المتوقعة 👈 لنفترض ان الخلية المخصصة لادخال المجموع هي B2 In cell B2 =IFERROR(TRANSPOSE(xFormula(A2:A11; B2));"") وفي Module انسخ الكود التالي مع حفظ الملف بصيغة الماكرو Option Explicit '================29/06/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' '=========================================================================================== Public Function xFormula(rngNumbers As Range, XSum As Long) Dim arNumbers() As Long, tmp() As Long, arr() As String, F As Range, Cnt As Long ReDim arr(0) If rngNumbers.Count > 1 Then ReDim arNumbers(rngNumbers.Count - 1) Cnt = 0 For Each F In rngNumbers arNumbers(Cnt) = CLng(F.Value) Cnt = Cnt + 1 Next F Call Cpt(arNumbers, XSum, tmp(), arr()) End If ReDim Preserve arr(0 To UBound(arr) - 1) xFormula = arr End Function Private Sub Cpt(Numbers() As Long, target As Long, tmp() As Long, ByRef arr() As String) Dim s As Long, i As Long, j As Long, num As Long Dim Rng() As Long, tmpRec() As Long, n As Long s = a(tmp) If s = target Then n = UBound(arr) ReDim Preserve arr(0 To n + 1) arr(n) = b(tmp) End If If s > target Then Exit Sub If (Not Not Numbers) <> 0 Then For i = 0 To UBound(Numbers) Erase Rng() num = Numbers(i) For j = i + 1 To UBound(Numbers) Total Rng, Numbers(j) Next j Erase tmpRec() C tmpRec, tmp Total tmpRec, num Cpt Rng, target, tmpRec, arr Next i End If End Sub Private Function b(x() As Long) As String Dim n As Long, result As String result = " " & x(n) For n = LBound(x) + 1 To UBound(x) result = result & "-" & x(n) Next n result = result & " " b = result End Function Private Function a(x() As Long) As Long Dim n As Long a = 0 If (Not Not x) <> 0 Then For n = LBound(x) To UBound(x) a = a + x(n) Next n End If End Function Private Sub Total(arr() As Long, x As Long) If (Not Not arr) <> 0 Then ReDim Preserve arr(0 To UBound(arr) + 1) Else ReDim Preserve arr(0 To 0) End If arr(UBound(arr)) = x End Sub Private Sub C(destination() As Long, source() As Long) Dim n As Long If (Not Not source) <> 0 Then For n = 0 To UBound(source) Total destination, source(n) Next n End If End Sub ادا كنت تستخدم النسخ الحديثة من الاوفيس ضع المعادلة التالية في الخلية E2 للتحقق من مجموع القيم المستخرجة مع سحبها للاسفل =IF(D2<>"";SUM(FILTERXML("<x><y>"&SUBSTITUTE(TRIM(CONCAT(IFERROR(0+MID(D2;SEQUENCE(LEN(D2));1);" ")));" ";"</y><y>")&"</y></x>";"//y"));"") فحص مجموعة قيم لايجاد اى منها يساوى قيمة معينة.xlsm

غريب صراحة لا اعلم لمادا لانني جربت الملف عندي ويشتغل بشكل جيد و بدون ادنى مشكلة وللتأكد قمت بتجربته على جهاز اخر انظر الرابط التالي 👇 https://streamable.com/3m40n4 رغم انني متأكد من صحة الاكواد وبما ان كود التنازلي يعمل جرب هدا للتصاعدي و الترتيب الابجدي ووافينا بالنتيجة Sub Tri_Names_Ordre() 'ترتيب ابجدي Dim a() Dim r As Range a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value Set r = f.Range("C11:J" & f.[C65000].End(xlUp).Row) ' <<=======عمود الاسم======== Call Quick(a(), LBound(a), _ UBound(a), 1, True): r.Value2 = a End Sub '************* Sub Tri_Ordre_croissant() 'ترتيب تصاعدي Dim a() Dim r As Range a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value Set r = f.Range("C11:J" & f.[C65000].End(xlUp).Row) ' <<=======عمود المجموع======== Call Quick(a(), LBound(a), _ UBound(a), 7, True): r.Value2 = a End Sub فرز V4.xlsb

انت لم تنتبه انه لديك نفس قيمة المجموع للاسماء 🤔🤔🤔 فارس محمد عبد الرازق اسماعيل 676 عمار سيد عبد الرازق اسماعيل 676 الكود يقوم بتحديثها جرب تغيير الرقم وسوف تلاحظ الفرق

تفضل اخي @محمد زيدان2024 تم تعديل الاكواد لتتناسب مع طلبك Option Compare Text Public Property Get f() As Worksheet: Set f = Worksheets("12 د بنون") End Property '================29/06/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' '=========================================================================================== Sub TriTotal_Descending_Order() 'ترتيب تنازلي Dim a() Dim r As Range a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value Set r = f.Range("C11:J" & f.[C65000].End(xlUp).Row) ' تحديد نطاق معين 'a = [C11:J38].Value: Set r = [C11:J38] ' <<=======عمود المجموع======== Call Quick(a(), LBound(a), _ UBound(a), 7, False): r.Value2 = a End Sub '**********فرز سريع************* Sub Quick(a(), gauc, droi, Cnt, ordre) Total = a((gauc + droi) \ 2, Cnt) Rng = gauc: d = droi Do If ordre Then Do While a(Rng, Cnt) < Total: Rng = Rng + 1: Loop Do While Total < a(d, Cnt): d = d - 1: Loop Else Do While a(Rng, Cnt) > Total: Rng = Rng + 1: Loop Do While Total > a(d, Cnt): d = d - 1: Loop End If If Rng <= d Then For i = LBound(a, 2) To UBound(a, 2) temp = a(Rng, i): a(Rng, i) = a(d, i): a(d, i) = temp Next i Rng = Rng + 1: d = d - 1 End If Loop While Rng <= d If Rng < droi Then Call Quick(a, Rng, droi, Cnt, ordre) If gauc < d Then Call Quick(a, gauc, d, Cnt, ordre) End Sub '************************************ Sub Tri_Colmun_Name() 'ترتيب ابجدي Dim clé() As String, index() As Long, Rng As Range a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value Dim b(): Set Rng = f.[C11] ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2)) Set rCrit = CreateObject("System.Collections.Sortedlist") For i = LBound(a) To UBound(a) rCrit.Add a(i, 1) & i, i Next i For tmp = LBound(a) To UBound(a) For arr = LBound(a, 2) To UBound(a, 2) b(tmp, arr) = a(rCrit.GetByIndex(tmp - 1), arr) Next arr Next tmp Rng.Resize(UBound(b), UBound(b, 2)).Value2 = b End Sub '************************************* Sub Tri_Total_Colmun() 'ترتيب تصاعدي Dim clé() As String, index() As Long, Rng As Range a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value Dim b(): Set Rng = f.[C11] ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2)) Set rCrit = CreateObject("System.Collections.Sortedlist") For i = LBound(a) To UBound(a) rCrit.Add a(i, 7) & i, i Next i For tmp = LBound(a) To UBound(a) For arr = LBound(a, 2) To UBound(a, 2) b(tmp, arr) = a(rCrit.GetByIndex(tmp - 1), arr) Next arr Next tmp Rng.Resize(UBound(b), UBound(b, 2)).Value2 = b End Sub فرز V3.xlsb

تمام اخي محمد

طلبك غير واضح بالنسبة لي ربما لم استطع استوعابه يمكنك شرح المطلوب بشكل اكثر وضوحا عند الاجابة على هده الاسئلة اخي @محمد زيدان2024 ادا قمنا بترتيب كل عمود على حدى هدا سياثر على صحة البيانات المجاورة من تاريخ الميلاد وحتى عمود السنة في حالة قمنا بفرز عمود الاسم ابجديا مع تحديد جميع البيانات هدا من شانه ان ياثر على ترتيب عمود المجموع وعند محاولة ترتيبه هو الاخر سيأثر على بياناتك سوف يصبح مجموع محمد مثلا يقابل اسم جرجس

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

اخي الفاضل بما انك تريد شكل القوائم متتابعة و مترابطة لابد من اختيار القيم المرغوب تعبئتها على القوائم بطريقة هي الاخرى متتابعة لا يمكنك الاعتماد على الفراغات داخل المعادلة ولا اعتقد انه هناك معادلة من شانها فعل دالك بالطريقة المطلوبة على حسب علمي المتواضع لا اعلم عن طريقة اشتغالك على الملف ولا الهدف من وراء انشاء هده القوائم لاكن مجرد فكرة من شانها مساعدتك اظن ان استخدام الاكواد من الممكن ان يساعدك في هدا ويمكنك نوعا ما من تجاهل الفراغات داخل القوائم واعتبارها قيمة بحث بمعنى ادخال قيمة الصف الاول ولتكن (دهوك) على القائمة الاولى واختيار قيمة فارغة في القائمة 2 و 3 مثلا للحصول على على قيمة الصف الرابع التي يقابلها شرط دهوك في الصف 1 والفراغات في الصف 2 و3 وهكدا مع القوائم الخمس . واخيرا ترحيل القيم المختارة للجدول الثاني اسفل بعضها ادا لم يكن عندك مانع لاستخدامها يكفي انشاء يوزرفورم صغير على الملف يتضمن 5 Combobox وزر وسوف احاول كتابة الاكواد الخاصة بدالك للتجربة

'In cell P4 =UNIQUE(FILTER(B5:B300,B5:B300<>"")) 'In cell Q4 =SORT(UNIQUE(FILTER(C5:C300,(C5:C300 <>"")*( B5:B300=I5),""))) 'In cell R4 =SORT(UNIQUE(FILTER(D5:D300,(D5:D300 <>"")*( B5:B300=I5)*( C5:C300=J5),""))) 'In cell S4 =SORT(UNIQUE(FILTER(E5:E300,(E5:E300 <>"")*( B5:B300=I5)*( C5:C300=J5)*( D5:D300=K5),""))) 'In cell T4 =SORT(UNIQUE(FILTER(F5:F300,(F5:F300 <>"")*( B5:B300=I5)*( C5:C300=J5)*( D5:D300=K5)*( E5:E300=L5),""))) Create drop-down lists Cells i5 =$P$4# / Cells j5 =$Q$4# / Cells k5 =$R$4# / Cells L5 =$S$4# / Cells M5 =$T$4# عمل قائمة منسدلة.xlsx

العفو أخي سعد يسعدنا أننا إستطعنا مساعدتك بالتوفيق.

لم اجد الكود داخل الملف ولا اعلم اسم الورقة المرغوب تنفيد الكود عليها

اذا كنت قد فهمت طلبك بشكل صحيح فالتعديل التالي سوف يوفي بالغرض Option Compare Text Dim a, i As Long Dim OneRng(), Rng, rCrit1, rCrit2 Dim d As Object, ComboAry As Variant Private Const Cpt As String = "Compte magasin" Private Const tbl As String = "Table1" Dim Crit(), headers(), choix(), colClé, Cnt, Item_Code Private Sub UserForm_Initialize() Dim Irow& Set f = Sheets(Cpt) a = Sheets(Cpt).ListObjects("Table1").DataBodyRange.Columns("A:X") Set d = CreateObject("scripting.dictionary") d.CompareMode = vbTextCompare Irow = f.Columns("I:N").Find(What:="*", SearchDirection:=xlPrevious, _ SearchOrder:=xlByRows).Row Set Cnt = f.Range("G2:N" & Irow): Crit = Cnt.value headers = Application.Index(Cnt.Offset(-1).value, 1) Me.ComboBox10.List = Application.Transpose(f.Range("J1:N1").value) ComboAry = Array("ComboBox1", "ComboBox3", "ComboBox5", _ "ComboBox9", "ComboBox10", "ComboBox13", "ComboBox12") For i = 0 To UBound(ComboAry): Me.Controls(ComboAry(i)).value = "*": Next i '''''''' Code..... ''''''''''''''''''''' End Sub ******************************************************************** Private Sub ComboBox10_Change() Item_Code = Val(Me.ComboBox12): Prices = Me.ComboBox10 If IsNumeric(Me.ComboBox10) Then _ tmp = Val(Me.ComboBox10) Else tmp = Prices colClé = Application.Match(tmp, headers, 0) For i = LBound(Crit) To UBound(Crit) If UCase(Crit(i, 1)) = UCase(Item_Code) And _ Prices <> "*" Then Me.TextBox7.value = Crit(i, colClé) Next i End Sub بيانات فاتورة 3.xlsm

ارفق ملفك أخي الكريم ليتم إسقاط الكود للتجربة مع توضيح شكل البيانات المتوقع

ماذا تقصد هل قمت بحل المشكلة بخصوص الطلب الثاني !!

الكود بطريقة اخرى مع الشرح لتتمكن من تعديله بما يناسبك Public Sub CopyData2() Dim rCrit() As String: ReDim rCrit(1 To 2): Const SrcRow = "EA" Dim x&, i&, Cnt&, arr&, lr&, lastRow&, Cpt As Long Dim Search_Row As Long, Star_Row As Long, Col As Range Dim rngA As Variant, rngB As Variant, OneRng As Range Dim WS As Worksheet: Set WS = Sheets("cheet4") Dim srcWS As Worksheet: Set srcWS = Sheets("شيت الدور الثاني صف رابع ") ' تحديد صف البداية Star_Row = 16: ' عمود الفلترة Search_Row = 131 'تحديد صف وضع البيانات المرحلة Cnt = 10 With Application .ScreenUpdating = False .Calculation = xlManual lastRow = WS.Range(SrcRow & WS.Rows.Count).End(xlUp).Row lr = srcWS.Columns("C:AP").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row 'معايير الفلترة rCrit(1) = "غ": rCrit(2) = "*" & "دور ثان" & "*" 'الاعمدة المرحلة rngA = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _ 28, 40, 52, 64, 76, 88, 100, 112, 116, Search_Row) 'الاعمدة المرحل اليها rngB = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, _ 15, 18, 21, 24, 27, 30, 33, 36, 39, 42) '("EA")'التحقق من وجود المعايير على عمود arr = Application.Sum _ (Application.IfError(Application.Match(rCrit, WS.Columns(Search_Row), 0), 0)) If arr = 0 Then: MsgBox " المرجوا التحقق من صحة المعايير ", _ vbCritical, "انتباه": Exit Sub 'افراغ البيانات السابقة For x = 0 To UBound(rngB) Set Col = srcWS.Range(srcWS.Cells(Cnt, rngB(x)), srcWS.Cells(lr, rngB(x))) Col.ClearContents Next x With WS If .AutoFilterMode Then .AutoFilterMode = False ' تحديد نطاق البيانات With WS.Range("C15:EA15") .AutoFilter Search_Row - 2, rCrit, xlFilterValues ' نسخ الاعمدة المرئية For i = 0 To UBound(rngA) Set OneRng = WS.Range(WS.Cells(Star_Row, _ rngA(i)), WS.Cells(lastRow, rngA(i))).SpecialCells(xlCellTypeVisible) OneRng.Copy 'لصق البيانات srcWS.Cells(Cnt, rngB(i)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats Next i .AutoFilter End With End With .CutCopyMode = False .Calculation = xlAutomatic .ScreenUpdating = True End With End Sub SAAD V3.xlsm

لا اخي ليس لها علاقة الملف يشتغل معي بشكل جيد جدا وبدون ادنى مشكلة ما هو اصدار الاوفيس لديك اخي سعد

اعتقد انه هناك سوء تفاهم ما هي النتيجة المتوقعة على اخر عمود رقم 42 انظر الصورة