محمد هشام.

قم بتعديل هذا السطر For Each pic In WS.Pictures الى For Each pic In f.Pictures

وعليكم السلام ورحمة الله نعالى وبركاته اظن انه يجب عليك اولا تغيير مكان خلية اختيار اسم المادة (N1) خارج نطاق البحث لانه في حالة تم اخفاء عمود مادة الدين مثلا عمود (N) سيتم اخفاء خلية الاختيار لنفترض ان الخلية المحددة هي (R1) Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Target.Worksheet.Range("R1")) Is Nothing Then Dim x As Range, rng As Range Set x = Clé([R1], [G7:P7]): Set rng = Columns("E:F") Application.ScreenUpdating = False If x Is Nothing Then MsgBox "مادة" & " " & [R1] & " : " & " غير موجودة ", vbExclamation: Exit Sub Columns("C:P").EntireColumn.Hidden = True x.EntireColumn.Hidden = False: rng.EntireColumn.Hidden = False ActiveWindow.ScrollColumn = 1 End If End Sub Function Clé(a, b As Range) As Range Dim i& On Error Resume Next i = WorksheetFunction.Match(a, b, 0) If i Then Set Clé = b(i) End Function اظهار الاعمدة Sub Show_all_columns() Sheets("Sheet1").Columns("C:P").EntireColumn.Hidden = False End Sub بطريقة اخرى Sub Hide_columns() Dim Clé As Variant, desWS As Worksheet, rng As Range Set desWS = ThisWorkbook.Sheets("Sheet1"): Clé = [R1].Value If Clé > 0 Then With desWS Set rng = .Rows(7).Find(Clé, LookIn:=xlValues, lookat:=xlWhole) If Not rng Is Nothing Then Application.ScreenUpdating = False .Columns("C:P").EntireColumn.Hidden = True rng.EntireColumn.Hidden = False .Columns("E:F").EntireColumn.Hidden = False Else MsgBox "مادة" & " " & Clé & " : " & " غير موجودة ", vbExclamation: Exit Sub End If End With End If ActiveWindow.ScrollColumn = 1 Application.ScreenUpdating = True End Sub صفحة الرصد V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته لجلب الصور دفعة واحدة يكفي الوقوف بمؤشر الماوس على اول خلية فارغة على عمود الصور وتشغيل الكود التالي مع تحديد الصور المرغوب اظافتها Sub InsertMultiplePictures() 'اظافة الصور' Set WS = Sheets("ادخال البيانات") Dim Pictures() As Variant Dim j As String, Rng As Range, Cpt As Shape On Error Resume Next Pictures = Application.GetOpenFilename(j, MultiSelect:=True) a = Application.ActiveCell.Column If IsArray(Pictures) Then Col = Application.ActiveCell.Row For lLoop = LBound(Pictures) To UBound(Pictures) Set Rng = Cells(Col, a) Set Cpt = WS.Shapes.AddPicture(Pictures(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height) Col = Col + 1 Next End If End Sub لافراغ عمود الصور Sub DeleteImage() Dim pic As Picture Set f = Sheets("ادخال البيانات") For Each pic In WS.Pictures If Not Application.Intersect(pic.TopLeftCell, f.Range("G6:G200")) Is Nothing Then pic.Delete End If Next pic End Sub الجدول 1 =INDEX('ادخال البيانات'!$B$6:$G$2000;MATCH('طبع البيانات'!$C$10;'ادخال البيانات'!$B$6:$B$2000;0);6) =MyPicture الجدول 2 =INDEX('ادخال البيانات'!$B$6:$G$2000;MATCH('طبع البيانات'!$C$36;'ادخال البيانات'!$B$6:$B$2000;0);6) =MyPicture2 واخيرا ربط الصور بالنطاق الجمعيه الخيريه 2.xlsb

😁😁😁 بارك الله في اخي سعد يسعدنا اننا استطعنا مساعدتك

وعليكم السلام ورحمة الله تعالى وبركاته Private Sub TextBox1_Change() Dim a As Variant, b As Variant, Clé$, Rng As Range, i&, j&, k&, m& Dim WS As Worksheet: Set WS = Worksheets("donnes") Dim desWS As Worksheet: Set desWS = Worksheets("search") Clé = "*" & desWS.[B3].Value & "*" Set Rng = desWS.Range("A6:G" & Rows.Count) a = WS.Range("D5", WS.Range("J" & Rows.Count).End(3)).Value If Me.TextBox1 = "" Then Rng.ClearContents Else Application.ScreenUpdating = False With desWS On Error Resume Next .AutoFilterMode = False ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)) For i = 1 To UBound(a, 1) For j = 1 To UBound(a, 2) 'Filter by Uppercase and lowercase letters If LCase(a(i, j)) Like Clé Or UCase(a(i, j)) Like Clé Then k = k + 1 For m = 1 To UBound(a, 2) b(k, m) = a(i, m) Next Exit For End If Next Next Rng.ClearContents: Range("A6").Resize(k, UBound(b, 2)).Value = b Range("d6:d" & Rows.Count).NumberFormat = "dd-mm-yyyy" End With End If Application.ScreenUpdating = True End Sub بحث VBA V2.xlsm

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

نعم اخي لاننا قمنا بعرض البيانات على الليست بوكس بداية من العمود رقم 2 (التاريخ) فمن الطبيعي عند الترحيل سيتم نسخ البيانات بداية من نفس العمود حاول اخي في المرة المقبلة تزويد طلبك بمعطيات كافية .تفاديا لاهدار الوقت والاشتغال على الملف اكثر من مرة .فمسالة التعديل ليست بالسهلة . على العموم تفضل اخي تم نعديل اكواد الترحيل وانشاء صفحات المقاولين مع مراعات جميع الاحتمالات الواردة على ما اظن في انتظارك بعد التجربة..........😁 كلمة المرور 0 مستخلصات الاعمال الجنوبية- V3.xlsm

تفضل اخي مستخلصات الاعمال الجنوبية- V2.xlsm

التغيير اخي سوف يكون هنا لكن يجب اولا اظافة الشرط الثاني ودالك باظافة كومبوبوكس جديدة وليكن اسمه T2 مثلا من If Rng(i, 4) >= Clé Then الى If rng(i, 4) >= Clé And rng(i, 4) <= Clé2 Then وافراغ جميع الاكواد السابقة من على اليوزرفورم ونسخ الكود التالي Dim F, rng, Col, width, j, Total() Private Sub UserForm_Initialize() Dim WS As Worksheet: Set WS = Sheets("data") Set d = CreateObject("scripting.dictionary") Set F = WS.Range("A2:E" & WS.[C65000].End(xlUp).Row) rng = F.Value ' الاعمدة الظاهرة على الليست بوكس Col = Array(5, 4, 3, 2, 1) width = Array(100, 100, 100, 100, 100) ' تنسيق عمود المبلغ For i = LBound(rng) To UBound(rng): rng(i, 5) = Format(rng(i, 5), "#,##00.00"): Next i Me.Ls_ATA.ColumnCount = UBound(Col) + 1 Me.Ls_ATA.ColumnWidths = Join(width, ";") Me.Ls_ATA.List = Application.Index(F, Evaluate("Row(1:" & F.Rows.Count & ")"), Col) Total = Col: j = UBound(Total) + 1 ' عمود الفلترة ColTri = 4 For i = LBound(rng) To UBound(rng) d(rng(i, ColTri)) = "" Next i ValTri = d.keys ' ترتيب عدد الفواتير على الليست من الاصغر الى الاكبر P rng, 4, LBound(rng), UBound(rng) ' ترتيب تصاعدي لارقام الفواتير tri ValTri, LBound(ValTri), UBound(ValTri) ' جلب اصغر عدد Me.T1.List = ValTri: Me.T1 = ValTri(0) ' جلب اكبر عدد Me.T2.List = ValTri: Me.T2 = ValTri(UBound(ValTri)) MySum End Sub '***************** Sub Filtre() 'فلترة البيانات Dim Tbl(): n = 0: Clé = Val(Me.T1): Clé2 = Val(Me.T2) For i = 1 To UBound(rng) If rng(i, 4) >= Clé And rng(i, 4) <= Clé2 Then n = n + 1: ReDim Preserve Tbl(1 To j, 1 To n) C = 0 For Each k In Total C = C + 1: Tbl(C, n) = rng(i, k) Next k End If Next i If n > 0 Then Me.Ls_ATA.Column = Tbl MySum Else Me.Ls_ATA.Clear End If End Sub '******combobox (T1 AND T2) 'ترتيب تصاعدي************* Sub tri(a, gauc, droi) ref = a((gauc + droi) \ 2) g = gauc: d = droi Do Do While a(g) < ref: g = g + 1: Loop Do While ref < a(d): d = d - 1: Loop If g <= d Then temp = a(g): a(g) = a(d): a(d) = temp g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call tri(a, g, droi) If gauc < d Then Call tri(a, gauc, d) End Sub '***ترتيب عدد الفواتير على الليست من الاصغر الى الاكبر****** Sub P(a, V, gauc, droi) ref = a((gauc + droi) \ 2, V) g = gauc: d = droi Do Do While a(g, V) < ref: g = g + 1: Loop Do While ref < a(d, V): d = d - 1: Loop If g <= d Then For k = LBound(a, 2) To UBound(a, 2) temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp Next k g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call P(a, V, g, droi) If gauc < d Then Call P(a, V, gauc, d) End Sub '******************************* Sub MySum() Dim Cpt2 As Double, Cpt1 As Double, Cnt As Long Cnt = 0: Cpt = 0: Cpt1 = 0: Cpt2 = 0 With Ls_ATA For r = 0 To .ListCount - 1 Cnt = Cnt + 1 'عدد النتائج Cpt1 = Cpt1 + .List(r, 0) ' مجموع الفواتير Cpt2 = Cpt2 + .List(r, 1) ' اجمالي المبلغ Next r End With LabelCont.Caption = Cnt: SubTotal.Value = Format(Cpt1, "#,##00.00"):: SubTotal2.Value = Cpt2 End Sub '******************************* Private Sub T2_click() If Val(Me.T2) < Val(Me.T1) Then MsgBox "يجب أن يكون الحد الادنى لعدد الفواتير اكبر اويساوي " & Me.T1.Text, vbExclamation, "انتباه" Else Filtre End Sub Private Sub T1_click() If Val(Me.T1) > Val(Me.T2) Then MsgBox "يجب أن يكون الحد الاقصى لعدد الفواتير اصغر او يساوي " & Me.T2.Text, vbExclamation, "انتباه" Else Filtre End Sub اليك الملف للتجربة V3 تجربة (1).xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Sub transfert() Dim desWS As Worksheet: Set desWS = Sheets("تجميع") Dim i As Byte, F As Variant Application.ScreenUpdating = False desWS.Range("a2:j" & Rows.Count).ClearContents For i = 1 To Worksheets.Count If UCase(Sheets(i).Name) <> desWS.Name Then With Sheets(i) F = .Range("A10:G10", .Range("a" & Rows.Count).End(xlUp)) desWS.[A65000].End(xlUp).Offset(2).Resize(UBound(F), 7) = F End With End If Next Application.ScreenUpdating = True End Sub في حالة الرغبة بتنسيق الجداول يمكنك اظافة الاسطر التالية اسفل الكود 'تنسيق الجداول '''*****تسطير***** With desWS lastrow = .Range("A:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngCell = .Range("A2 :G" & lastrow) For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next '''****تمييز رؤوس الاعمدة*** Set j = .Range("a2:a" & lastrow) For Each r In j If r.Value = "ر.ت" Then _ If rng Is Nothing Then Set rng = r.Resize(1, 7) Else Set rng = Union(rng, r.Resize(1, 7)) Next If Not rng Is Nothing Then rng.Interior.Color = RGB(204, 204, 255): rng.Font.Bold = True End With ListEleve_20240320 V2.xlsm

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

وعليكم السلام ورحمة الله تعالى وبركاته Dim F, Rng, Col, width, j, Total() Private Sub UserForm_Initialize() Dim WS As Worksheet: Set WS = Sheets("data") Set d = CreateObject("scripting.dictionary") Set F = WS.Range("A2:E" & WS.[C65000].End(xlUp).Row) Rng = F.Value Col = Array(5, 4, 3, 2, 1) width = Array(100, 100, 100, 100, 100) For i = LBound(Rng) To UBound(Rng): Rng(i, 5) = Format(Rng(i, 5), "#,##00.00"): Next i Me.Ls_ATA.ColumnCount = UBound(Col) + 1 Me.Ls_ATA.ColumnWidths = Join(width, ";") Me.Ls_ATA.List = Application.Index(F, Evaluate("Row(1:" & F.Rows.Count & ")"), Col) Total = Array(5, 4, 3, 2, 1): j = UBound(Total) + 1 d("*") = "" For i = 1 To UBound(Rng) d(Rng(i, 4)) = "" Next i r = d.keys Me.T1.List = r: Me.T1 = "*" MySum End Sub '********************* Private Sub T1_click() Dim Tbl(): n = 0: Clé = Val(Me.T1) For i = 1 To UBound(Rng) If Rng(i, 4) >= Clé Then n = n + 1: ReDim Preserve Tbl(1 To j, 1 To n) C = 0 For Each k In Total C = C + 1: Tbl(C, n) = Rng(i, k) Next k End If Next i If n > 0 Then Me.Ls_ATA.Column = Tbl MySum Else Me.Ls_ATA.Clear End If End Sub '******************* Sub MySum() Dim Cpt2 As Double, Cpt1 As Double, Cnt As Long Cnt = 0: Cpt = 0: Cpt1 = 0: Cpt2 = 0 With Ls_ATA For r = 0 To .ListCount - 1 Cnt = Cnt + 1 'عدد النتائج Cpt1 = Cpt1 + .List(r, 0) ' مجموع الفواتير Cpt2 = Cpt2 + .List(r, 1) ' اجمالي المبلغ Next r End With LabelCont.Caption = Cnt: SubTotal.Value = Format(Cpt1, "#,##00.00"):: SubTotal2.Value = Cpt2 End Sub V2 تجربة.xlsm

حاول أخي إرفاق ملف يتضمن بعض البيانات الوهمية للاشتغال عليه

Sub Delete_duplicate_condition() Dim I As Integer, Cpt As String Dim A As Integer, b As Integer Dim WS As Worksheet: Set WS = Sheets("Sheet1") lr = WS.Columns("B:B").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row For I = lr To 2 Step -1 Cpt = Range("B" & I).Value A = Application.WorksheetFunction.MaxIfs(Range("E:E"), Range("B:B"), Cpt) b = Application.WorksheetFunction.MinIfs(Range("E:E"), Range("B:B"), Cpt) If Range("E" & I).Value <> A And Range("E" & I).Value <> b Then Range("B" & I & ":E" & I).Delete End If If Range("b" & I) = "" And Range("E" & I) = "" Then Range("B" & I & ":E" & I).Delete Next I End Sub

ادن ما هي النتيجة المتوقعة في حالة وجود نفس القيمة مكررة مرتين فقط او 3

وعليكم السلام ورحمة الله تعالى وبركاته بالنسبة لطلبك الاول يمكنك استخدام الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) IRow = Cells.Find("*", , xlFormulas, , xlRows, xlPrevious).Row Dim r As Range: Set r = Range("B2:B" & IRow) Dim Arr() As Variant: Arr = r.Value2 Dim Cpt() As Variant: ReDim Cpt(1 To UBound(Arr), 1 To 1) On Error Resume Next Application.EnableEvents = False If Target.Column = 2 And Target.Row >= 2 Then Select Case LCase(Target.Value) Case Is <> "" With CreateObject("Scripting.DictionAry") For i = 1 To UBound(Arr) If Arr(i, 1) > 0 Then If Not .Exists(Arr(i, 1)) Then .Add Arr(i, 1), 1 Cpt(i, 1) = .Item(Arr(i, 1)) Else .Item(Arr(i, 1)) = .Item(Arr(i, 1)) + 1 Cpt(i, 1) = .Item(Arr(i, 1)) End If End If Next i r.Offset(, 3).Value2 = Cpt End With Case Is >= 0 Me.Cells(Target.Row, 5) = Empty End Select End If On Error GoTo 0 Application.EnableEvents = True End Sub بالنسبة للطلب الثاني ربما يجب عليك التوضيح اكثر هل تقصد عند تواجد اقل من 4 تكرارات يتم حدف اكبر قيمة فقط والاحتفاظ بالباقي او مادا حذف المكرر بشرط.xlsm

على شريط Excel، انتقل إلى علامة التبويب "الصيغ" > مجموعة الحساب، وانقر فوق الزر "خيارات الحساب" وحدد تلقائي (Automatic)

تفضل اليك الحلول التالية Sub ترحيل1() Dim Cpt As Long, Arr As Range, r As Range Dim a As Worksheet: Set a = Worksheets("Home"): Dim F As Worksheet: Set F = Worksheets("data") Cpt = F.Cells(F.Rows.Count, "B").End(xlUp).Row With Application .Calculation = xlManual .ScreenUpdating = False b = Array(a.[B2], a.[B3]): c = a.[F5] d = Array(a.[B4], a.[B5], a.[D2], a.[D3], a.[D4], a.[D5], a.[F2], a.[F3], a.[F4]) '***لعدم الترحيل في حالة العثور على خلية فارغة*** 'Set Arr = Union(a.[B2:B5], a.[D2:D5], a.[F2:F5]) ' For Each r In Arr ' If IsEmpty(r.Value) Or r.Value = vbNullString Then ' MsgBox " المرجوا ملء بيانات " & r.Offset(0, -1).Value, vbExclamation, "إنتباه" ' Exit Sub ' End If ' Next r '************************************************ F.Cells(Cpt + 1, "A") = F.Cells(Cpt + 1, "A").Row - 2 F.Cells(Cpt, "B").Offset(1).Resize(, 2).Value = b F.Cells(Cpt, "E").Offset(1).Resize(, 9).Value = d F.Cells(Cpt, "O").Offset(1).Value = c .Calculation = xlAutomatic .ScreenUpdating = True End With MsgBox "تم ترحيل البيانات بنجاح", vbInformation End Sub او Sub ترحيل2() Dim Cpt As Long Dim a As Worksheet: Set a = Sheets("Home"): Dim F As Worksheet: Set F = ThisWorkbook.Sheets("data") Cpt = F.Cells(F.Rows.Count, "B").End(xlUp).Row + 1 With Application .Calculation = xlManual .ScreenUpdating = False Arr = Array(a.[B2], a.[B3], a.[B4], a.[B5], a.[D2], a.[D3], a.[D4], a.[D5], a.[F2], a.[F3], a.[F4], a.[F5]) For I = 0 To 11 If Arr(I) = Empty Then MsgBox " المرجوا ملء بيانات " & Arr(I).Offset(0, -1), vbExclamation, "إنتباه" Exit Sub End If Next F.Cells(Cpt, "A") = F.Cells(Cpt, "A").Row - 2 F.Cells(Cpt, "B").Value = a.[B2].Value: F.Cells(Cpt, "G").Value = a.[D2].Value F.Cells(Cpt, "C").Value = a.[B3].Value: F.Cells(Cpt, "H").Value = a.[D3].Value F.Cells(Cpt, "E").Value = a.[B4].Value: F.Cells(Cpt, "I").Value = a.[D4].Value F.Cells(Cpt, "F").Value = a.[B5].Value: F.Cells(Cpt, "J").Value = a.[D5].Value F.Cells(Cpt, "K").Value = a.[F2].Value: F.Cells(Cpt, "L").Value = a.[F3].Value F.Cells(Cpt, "M").Value = a.[F4].Value: F.Cells(Cpt, "O").Value = a.[F5].Value .Calculation = xlAutomatic .ScreenUpdating = True End With MsgBox "تم ترحيل البيانات بنجاح", vbInformation End Sub 2024-3-15 ترحيل V2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Sub ÊÑÍíá2() Dim Ws As Worksheet, F As Worksheet Dim X As Long, I As Long, Arr Set Ws = Sheets("Home"): Set F = Sheets("data") X = F.Cells(Rows.Count, 2).End(3).Row + 1 Application.ScreenUpdating = False Arr = Array("B2", "B3", "", "B4", "B5", "D2", "D3", "D4", "D5", "F2", "F3", "F4", "", "F5") For I = LBound(Arr) To UBound(Arr) If Arr(I) <> "" Then Arr(I) = Ws.Range(Arr(I)).Value Next I F.Cells(X, 2).Resize(, UBound(Arr) + 1) = Arr F.Range("D3:D" & F.Range("B" & Rows.Count).End(3).Row) = "=($D$1-C3)/(365)" F.Range("N3:N" & F.Range("B" & Rows.Count).End(3).Row) = "=sum(k3+l3+m3)" F.Cells(X, 1) = F.Cells(X, 1).Row - 2 Application.ScreenUpdating = True End Sub او Sub ترحيل3() Dim Ws As Worksheet, F As Worksheet Dim X As Long, I As Long, Arr Set Ws = Sheets("Home"): Set F = Sheets("data") X = F.Cells(Rows.Count, 2).End(3).Row + 1 Application.ScreenUpdating = False Arr = Array("B2", "B3", "", "B4", "B5", "D2", "D3", "D4", "D5", "F2", "F3", "F4", "", "F5") For I = LBound(Arr) To UBound(Arr) If Arr(I) <> "" Then Arr(I) = Ws.Range(Arr(I)).Value Next I F.Cells(X, 2).Resize(, UBound(Arr) + 1) = Arr With F.Range("A3:A" & F.Range("B" & Rows.Count).End(xlUp).Row) .Formula = "=IF(B3="""","""",IF(B3=""Name"",""Count"",N(A2)+1))" .Value = .Value With F.Range("D3:D" & F.Range("B" & Rows.Count).End(3).Row) .Formula = "=($D$1-C3)/(365)" .Value = .Value With F.Range("N3:N" & F.Range("B" & Rows.Count).End(3).Row) .Formula = "=sum(k3+l3+m3)" .Value = .Value End With End With End With Application.ScreenUpdating = True End Sub 2024-3-15 ترحيل بيانات 2.xlsm

حل اخر بالاكواد للبحث بالاسم او الرقم Private Sub TextBox1_Change() 'Sheet Segl clinic Dim a As Variant, b As Variant, clé As String Dim i&, j&, k&, m& Dim WS As Worksheet: Set WS = Worksheets("Segl clinic") Dim F As Worksheet: Set F = Worksheets("search") If Me.TextBox1 = "" Then F.Range("b6:c" & Rows.Count).ClearContents Else On Error Resume Next a = WS.Range("F6", WS.Range("G" & Rows.Count).End(3)).Value ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)) clé = "*" & F.Range("b3").Value & "*" For i = 1 To UBound(a, 1) For j = 1 To UBound(a, 2) If LCase(a(i, j)) Like clé Then k = k + 1 For m = 1 To UBound(a, 2) b(k, m) = a(i, m) Next Exit For End If Next Next F.Range("B6:C" & Rows.Count).ClearContents F.Range("b6").Resize(k, UBound(b, 2)).Value = b End If End Sub '********************** Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then TextBox1.Value = "" End If End Sub العيادة VBA.xlsm

العيادة.xlsx

جرب شيء مثل هدا =IF(OR(G13>0;H13>0);IF(OR(G13="اجتاز";H13="اجتاز");"جدير";"غير جدير");"") =IF(OR(G13<>"";H13<>"");IF(OR(G13="اجتاز";H13="اجتاز");"جدير";"غير جدير");"")

ربما هدا ما تقصده تجربة فرز الرواتب.xlsx

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

لقد ألقيت نظرة أكثر قليلاً على الكود الخاص بي ، وقمت بحساب عدد الملفات الموجودة بالفعل في المجلد. واكتشفت أنه إذا قمت بحذف أي من الإصدارات الأقدم، فسيخرج رقم الإصدار الجديد من المزامنة ولن يستخدم الرقم الأحدث. إذا كنت مهتم بتجربة إصدار آخر، فاستبدل هذا الرمز: ' ' تسلسل اسم الملف F = 0 Do While Cpt <> "" F = F + 1 Cpt = Dir Loop '(Excel بصيغة)' ' حفظ الملف في المسار التالي Application.ActiveWorkbook.SaveAs Filename:=a(3) & "\" & a(1) & "_" & F + 1 & ".xlsx", FileFormat:=51 بهذا الكود: ' تسلسل اسم الملف Dim sVers As String Dim Réf As Long, F As Long Dim i As Long Do While Cpt <> "" sVers = Right(Left(Cpt, InStr(Cpt, ".xls") - 1), 4) Réf = 0 For i = Len(sVers) - 1 To 1 Step -1 If IsNumeric(Right(sVers, i)) Then Réf = Val(Right(sVers, i)) Exit For End If Next i If F < Réf Then F = Réf Cpt = Dir Loop '(Excel بصيغة)' ' حفظ الملف في المسار التالي Application.ActiveWorkbook.SaveAs Filename:=a(3) & "\" & a(1) & "_" & F + 1 & ".xlsx", FileFormat:=51