محمد هشام.

أخي @Hussein888 في Excel 365 يوجد خاصية تلقائية تعرف بـ AutoComplete التي تجعل القوائم المنسدلة تتفاعل بشكل ديناميكي مع الحروف التي تكتبها في الخلية حيث يتم تحديث القائمة لتظهر القيم التي تطابق ما كتبته لكن في Excel 2016 لا توجد هذه الخاصية بشكل افتراضي في القوائم المنسدلة المعتمدة على Data Validation ولكن هناك حل بديل باستخدام VBA كما في المثال التالي بما أنك لم تقم بإرفاق ملفك لتحديد النطاقات المطلوبة إليك الكود يمكنك تعديله بما يناسبك Option Compare Text Dim a() Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' تحديد نطاق القوائم المنسدلة If Not Intersect([A2:A10], Target) Is Nothing And Target.Count = 1 Then ' (الأسماء) تحديد نطاق البيانات Set Rng = Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row) Set tbl = CreateObject("Scripting.Dictionary") tbl.CompareMode = vbTextCompare For Each c In Rng If c.Value <> "" Then tbl(c.Value) = "" Next c a = tbl.Keys 'ترتيب ابجدي tri a, 1, UBound(a) With Me.ComboBox1 .List = a: .Top = Target.Top: .Left = Target.Left: .Width = Target.Width .Height = Target.Height + 3: .Visible = True: .Activate End With Else Me.ComboBox1.Visible = False End If End Sub Private Sub ComboBox1_Change() If Me.ComboBox1.Text <> "" Then Set tbl = CreateObject("Scripting.Dictionary") tmp = "*" & UCase(Me.ComboBox1.Text) & "*" ' البحث عن النص في أي مكان For Each c In a If UCase(c) Like tmp Then tbl(c) = "" Next c Me.ComboBox1.List = tbl.Keys Me.ComboBox1.DropDown End If ActiveCell.Value = Me.ComboBox1.Text End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Me.ComboBox1.List = a Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then ActiveCell.Offset(1).Select End Sub 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 Test-Data Validation.xlsb

المفروض ان تضع عينة للنتائج المتوقعة على ورقة العميل للتأكد من الخلايا المرحلة والأعمدة المرحل اليها حاول تعديل الكود التالي بما يناسبك Sub test() Dim srcWS As Worksheet, dest As Worksheet Dim f As String, Lr As Long Dim a(1 To 1, 1 To 3) As Variant Set srcWS = Sheets("تسجيل") f = srcWS.Range("C8").Value On Error Resume Next Set dest = ThisWorkbook.Sheets(f) On Error GoTo 0 If dest Is Nothing Then: MsgBox "ورقة العميل '" & f & "' غير موجودة", vbExclamation: Exit Sub If srcWS.Range("C7").Value = "اجل" Then a(1, 1) = Format(Date, "dd/mm/yyyy") ' التاريخ a(1, 2) = srcWS.[C4].Value & " " & srcWS.[C5].Value 'الوصف مع الكود a(1, 3) = srcWS.[C6].Value 'سعر البيع Lr = dest.Cells(dest.Rows.Count, "B").End(xlUp).Row + 1 dest.Range(dest.Cells(Lr, "B"), dest.Cells(Lr, "D")).Value = a MsgBox "تم الترحيل بنجاح إلى ورقة العميل " & f, vbInformation End If End Sub

وعليكم السلام ورحمة الله تعالى وبركاته لم توضح أخي @علي بطيخ سالم هل الزيادة ستنفد على العمودين معا او الى فقط اليك محاولة مني بالاكواد لتثبيث الزيادة في عمود ( من) بساعة دائما وزيادة مدة الدقائق المدخلة في عمود (الى) Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim crWS As Worksheet: Set crWS = Me Dim tmp As Date, n As Double, lastRow As Long, i As Long If Not Intersect(Target, crWS.Range("A2,B2")) Is Nothing Then If crWS.Range("A2").Value = "" Or Application.WorksheetFunction.IsText(crWS.Range("A2").Value) Then _ MsgBox "يرجى إدخال توقيت البداية", vbExclamation: Exit Sub If Not IsNumeric(crWS.Range("B2").Value) Or _ crWS.Range("B2").Value <= 0 Then: MsgBox "يرجى إدخال مدة الزيادة بالدقائق", vbExclamation: Exit Sub tmp = crWS.Range("A2").Value n = crWS.Range("B2").Value / 1440 lastRow = crWS.Cells(crWS.Rows.Count, "E").End(xlUp).Row If lastRow < 2 Then Exit Sub Application.ScreenUpdating = False crWS.Range("C2:D" & crWS.Cells(crWS.Rows.Count, "C").End(xlUp).Row).ClearContents For i = 2 To lastRow If crWS.Cells(i, "E").Value <> "" Then crWS.Cells(i, "C").Value = Format(tmp, "hh:mm") crWS.Cells(i, "D").Value = Format(tmp + n, "hh:mm") tmp = tmp + TimeSerial(1, 0, 0) ' لتنفيد الزيادة بالدقائق على العمودين من و الى ' tmp = tmp + n End If Next i Application.ScreenUpdating = True End If End Sub في حالة الرغبة بتنفيد الزيادة على العمودين tmp = tmp + n توقيت البداية.xlsb

ادن جرب الملف المرفق في المشاركة السابقة بعد التعديل '========= استبدل هدا '============== b = Left(j, Len(j) - Len(CStr(Val(j)))) Cnt = Val(Right(j, Len(j) - Len(b))) newCode = b & Cnt + 1 '====== بالكود التالي '========== Dim tmp As String, textPart As String For i = Len(j) To 1 Step -1 If IsNumeric(Mid(j, i, 1)) Then tmp = Mid(j, i, 1) & tmp Else textPart = Left(j, i) Exit For End If Next i

Sub TransferData2() Dim i As Long, Cnt As Long Dim ws As Worksheet, f As Worksheet, sWS As Worksheet Dim Sh As String, arr As Variant Dim tbl As ListObject, a As Range, lige As Range Dim j As String, newCode As String, b As String Set ws = ThisWorkbook.Sheets("تسجيل") Sh = ws.[G3].Value arr = Array(ws.[G4], ws.[G5], ws.[G6], ws.[G7]) For i = 0 To 3 If arr(i) = "" Then MsgBox "يرجى إدخال: " & arr(i).Offset(0, -1), vbExclamation, "إنتباه" ws.Activate: arr(i).Select Exit Sub End If Next On Error Resume Next Set f = ThisWorkbook.Sheets(Sh) On Error GoTo 0 If f Is Nothing Then MsgBox "قائمة المخزون " & Sh & " غير موجودة", vbExclamation Exit Sub End If If MsgBox("هل ترغب في ترحيل بيانات التسجيل؟", vbYesNo + vbQuestion, "تأكيد الترحيل") = vbNo Then Exit Sub Set tbl = f.ListObjects(1) On Error Resume Next Set lige = tbl.ListColumns(2).DataBodyRange.SpecialCells(xlCellTypeConstants).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) On Error GoTo 0 ' الكود الجديد If Not lige Is Nothing Then j = lige.Value '========= استبدل هدا '============== ' b = Left(j, Len(j) - Len(CStr(Val(j)))) ' Cnt = Val(Right(j, Len(j) - Len(b))) ' newCode = b & Cnt + 1 '====== بالكود التالي '========== Dim tmp As String, textPart As String For i = Len(j) To 1 Step -1 If IsNumeric(Mid(j, i, 1)) Then tmp = Mid(j, i, 1) & tmp Else textPart = Left(j, i) Exit For End If Next i If tmp <> "" Then Cnt = CLng(tmp) Else Cnt = 0 End If newCode = textPart & (Cnt + 1) Else newCode = ws.[G4].Value End If If Not lige Is Nothing Then Set a = lige.Offset(1, 0) Else Set a = tbl.ListColumns(2).DataBodyRange.Cells(1, 1) If a.Value <> "" Then Set a = tbl.ListColumns(2).DataBodyRange.Cells(tbl.ListRows.Count + 1, 1) End If End If a.Value = newCode ' الكود a.Offset(0, 5).Value = 1 ' الكمية a.Offset(0, 2).Value = arr(1) ' الاسم a.Offset(0, 3).Value = arr(2) ' الوصف a.Offset(0, 7).Value = arr(3) ' الملاحظات a.Offset(0, 9).Value = Format(Date, "dd/mmmm") ' التاريخ Set sWS = Sheets("المشتريات") Set tbl = sWS.ListObjects(1) On Error Resume Next Set lige = tbl.ListColumns(3).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious) On Error GoTo 0 If Not lige Is Nothing Then Set a = lige.Offset(1, 0) Else Set a = tbl.ListColumns(3).DataBodyRange.Cells(1, 1) If a.Value <> "" Then Set a = tbl.ListColumns(3).DataBodyRange.Cells(tbl.ListRows.Count + 1, 1) End If End If a.Cells(1, 1).Offset(0, -1).Value = Format(Date, "dd/mmmm") ' التاريخ a.Value = newCode ' الكود a.Offset(0, 5).Value = 1 ' الكمية a.Offset(0, 2).Value = arr(1) ' الاسم a.Offset(0, 3).Value = arr(2) ' الوصف a.Offset(0, 7).Value = arr(3) ' الملاحظات a.Offset(0, 9).Value = Format(Date, "dd/mmmm") ' التاريخ End Sub مبيعات ومشتريات V3.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim n As Range, f As String, count As Integer, i As Integer If Not Intersect(Target, Me.Range("A1:B2")) Is Nothing Then Dim WS As Worksheet: Set WS = Sheets("data") Dim xRow As Range: Set xRow = WS.Range("A1:J1") Dim tmp As Integer: tmp = xRow.Column xRow.ClearContents For Each n In Me.Range("A1:A2") If n.Value <> "" Then f = n.Value count = n.Offset(0, 1).Value For i = 1 To count If tmp > xRow.Columns.count + xRow.Column - 1 Then Exit Sub WS.Cells(xRow.Row, tmp).Value = f tmp = tmp + 1 Next i End If Next n End If End Sub test2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته Sub MergeTotal() Dim WS As Worksheet, crWS As Worksheet, LastRow As Long, Irow As Long On Error Resume Next Set crWS = Sheets("total") On Error GoTo 0 If crWS Is Nothing Then MsgBox " غير موجودة total ورقة ", vbInformation Exit Sub Else Application.ScreenUpdating = False crWS.Range("A2:O" & crWS.Rows.Count).Clear End If Irow = 2 For Each WS In ThisWorkbook.Sheets If WS.Name <> crWS.Name Then LastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If LastRow >= 2 Then WS.Range("A2:O" & LastRow).Copy crWS.Cells(Irow, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme Irow = crWS.Cells(crWS.Rows.Count, 1).End(xlUp).Row + 1 End If End If Next WS Application.CutCopyMode = False Application.ScreenUpdating = True End Sub or Sub MergeTotal() Dim WS As Worksheet, Src As Worksheet Dim OnRng As Variant, rng As Range, r As Range Dim lastRow As Long, tmp As Long, col As Integer Set WS = Sheets("total") Application.ScreenUpdating = False lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row If lastRow > 1 Then: WS.Rows("2:" & lastRow).Clear tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 For Each Src In ThisWorkbook.Sheets If Src.Name <> WS.Name Then OnRng = Src.Range("A2:O" & Src.Cells(Src.Rows.Count, "A").End(xlUp).Row).Value WS.Cells(tmp, 1).Resize(UBound(OnRng, 1), UBound(OnRng, 2)).Value = OnRng For lastRow = 1 To Src.Cells(Src.Rows.Count, "A").End(xlUp).Row WS.Rows(tmp + lastRow - 1).RowHeight = 18.5 Next lastRow tmp = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row + 1 End If Next Src With WS.Range("A1:O" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row) .Borders.LineStyle = xlContinuous: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With Application.ScreenUpdating = True End Sub الرواتب.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد إذن الأستاد @عبدالله بشير عبدالله بما ان الكود الخاص به يعتمد على التنسيق إليك حل آخر باظهار رسالة تنبيه عند تجاوز الحد الاقصى للتكرارات بشرط التاريخ في عمود b [نفس الشهر ] واسم المهنة عمود d والحالة في عمود F طريقة الإدخال الكود_ المهنة _الحالة Private Sub Worksheet_Change(ByVal Target As Range) Dim lastRow As Long, Max As Integer, kay As Variant, xdate As Variant Max = 5 Application.EnableEvents = False lastRow = Cells(Rows.Count, 4).End(xlUp).Row If Not Intersect(Target, Me.Columns("B")) Is Nothing Then For Each cell In Target If cell.Value <> "" And IsEmpty(cell.Offset(0, 1).Value) Then cell.Offset(0, 1).Value = Date Else cell.Offset(0, 1).Value = "" End If Next cell End If If Not Intersect(Target, Me.Range("C5:F" & lastRow)) Is Nothing Then For Each cell In Target If cell.Column = 6 And cell.Value = "إجازة" Then kay = cell.Offset(0, -2).Value xdate = cell.Offset(0, -3).Value If IsEmpty(kay) Or IsEmpty(xdate) Then MsgBox "يجب إدخال كود الموظف", vbExclamation, "إنتبـــــاه" cell.ClearContents GoTo SupAPP End If If WorksheetFunction.CountIfs(Range("D5:D" & _ lastRow), kay, Range("F5:F" & lastRow), "إجازة", Range("C5:C" & lastRow), xdate) > 1 Then cell.ClearContents MsgBox " تم الوصول للحد الأقصى للإجازات هدا الشهر لسائقين :" & _ " " & kay, vbExclamation, "إنتبـــــاه" GoTo SupAPP End If If WorksheetFunction.CountIfs(Range("D5:D" & _ lastRow), kay, Range("F5:F" & lastRow), "إجازة", Range("C5:C" & lastRow), ">=" & WorksheetFunction.EoMonth(xdate, -1) + 1, _ Range("C5:C" & lastRow), "<=" & WorksheetFunction.EoMonth(xdate, 0)) > Max Then cell.ClearContents MsgBox "وصلت للحد الأقصى لهذا الشهر في إجازات السائق: " & kay, vbExclamation, "إنتبـــــاه" End If End If SupAPP: Next cell End If Application.EnableEvents = True End Sub اجاز V1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد إدن الأستاد @عبدالله بشير عبدالله إليك حلول أخرى =IF(A1>3000, A1*IF(B1<=500, 1.5, 2.5), IF(B1<500, 6000, "")) =IFERROR(IFS( AND(A1>3000, B1<=500), A1*1.5, AND(A1>3000, B1>500), A1*2.5, AND(A1<=3000, B1<500), 6000, TRUE, "" ), "") او Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("A:B")) Is Nothing Then Dim data As Variant, tmp() As Variant, lastRow As Long, i As Long Dim a As Double: a = 3000: b = 500: c = 6000 lastRow = Me.Cells(Me.Rows.Count, "A").End(xlUp).Row data = Me.Range("A1:B" & lastRow).Value ReDim tmp(1 To UBound(data, 1), 1 To 1) For i = 1 To UBound(data, 1) If IsEmpty(data(i, 1)) Or IsEmpty(data(i, 2)) Then tmp(i, 1) = "" ElseIf IsNumeric(data(i, 1)) And IsNumeric(data(i, 2)) Then If data(i, 1) > a Then tmp(i, 1) = IIf(data(i, 2) <= b, data(i, 1) * 1.5, data(i, 1) * 2.5) ElseIf data(i, 2) < b Then tmp(i, 1) = c Else tmp(i, 1) = "" End If Else tmp(i, 1) = "" End If Next i Me.Range("C1:C" & lastRow).Value = tmp End If End Sub test2025.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته ادا كان هدا ما تقصده جرب هدا =IFERROR(TEXT(DATE(2000+LEFT(B2,2),MID(B2,3,2),RIGHT(B2,2)),"DD/MM/YYYY"),"") او Option Explicit Sub ConvertDate() Dim lr As Long, r As Long, xDate As String, n As String Dim scWS As Worksheet: Set scWS = Sheets("Sheet1") lr = scWS.Cells(scWS.Rows.Count, "B").End(xlUp).Row For r = 2 To lr xDate = scWS.Cells(r, "B").Value If xDate <> "" Then n = Format(DateSerial(2000 + Left(xDate, 2), _ Mid(xDate, 3, 2), _ Right(xDate, 2)), "dd/mm/yyyy") scWS.Cells(r, "D").Value = n End If Next r End Sub New Microsoft Excel Worksheet.xlsx

نعم اخي @hanykassem نظرا للمثال المرفق هناك بعض الإحتمالات الواردة في حالة كان هناك تكرار لنفس القيم كما هو موضح في الصورة أدناه Private Sub Worksheet_Change(ByVal Target As Range) Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim i As Long, ling As Long, lastRow As Long, tmp As String, kayB As String, kayC As String, _ j As Variant, a As Object, r As Object Set a = CreateObject("Scripting.Dictionary"): Set r = CreateObject("Scripting.Dictionary") If Not Intersect(Target, WS.Range("A4:C" & WS.Rows.Count)) Is Nothing Then Application.ScreenUpdating = False With WS .Range("I3:K" & .Rows.Count).ClearContents lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ling = 3 For i = 4 To lastRow tmp = .Cells(i, 1).value kayB = .Cells(i, 2).value kayC = .Cells(i, 3).value If tmp <> "" Then If kayB <> "" Then a(tmp) = IIf(a.Exists(tmp), a(tmp) & " , " & kayB, kayB) If kayC <> "" Then r(tmp) = IIf(r.Exists(tmp), r(tmp) & " , " & kayC, kayC) End If Next i For Each j In a.Keys .Cells(ling, 9).value = j .Cells(ling, 10).value = a(j) .Cells(ling, 11).value = r(j) ling = ling + 1 Next j .Columns("j:K").AutoFit End With Application.ScreenUpdating = True End If End Sub لحدف التكرارات قم بتعديل الصف التالي If tmp <> "" Then If kayB <> "" Then a(tmp) = IIf(a.Exists(tmp), a(tmp) & " , " & kayB, kayB) If kayC <> "" Then r(tmp) = IIf(r.Exists(tmp), r(tmp) & " , " & kayC, kayC) End If إلى If tmp <> "" Then If kayB <> "" Then If Not a.Exists(tmp) Then a.Add tmp, _ kayB Else If InStr(1, a(tmp), kayB) = 0 Then a(tmp) = a(tmp) & " , " & kayB If kayC <> "" Then If Not r.Exists(tmp) Then r.Add tmp, _ kayC Else If InStr(1, r(tmp), kayC) = 0 Then r(tmp) = r(tmp) & " , " & kayC End If TEST CODE 2.xlsb

يمكنك تعديل كود عرض الأعمدة بترتيب العناصر على الشكل التالي Private Sub ContrArr(tmp As Long) Dim controls As Variant, columns As Variant, i As Integer controls = Array("TextBox7", "ComboBox1", "ComboBox2", "ComboBox3", "ComboBox4", _ "TextBox3", "TextBox4", "TextBox5", "TextBox6", "ComboBox5") columns = Array(2, 4, 5, 6, 7, 8, 9, 10, 11, 12) If Me.TextBox8.Text = "" Then ClearControls Else Me.TextBox8.Tag = tmp For i = LBound(controls) To UBound(controls) Me.controls(controls(i)).Text = WS.Cells(tmp, columns(i)).Value Next i tblUpdate tmp End If End Sub البحث والتنقل.rar

وعليكم السلام ورحمة الله تعالى وبركاته ربما هدا ما تقصده ادا كنت قد فهمت طلبك بشكل صحيح يمكنك حدف جميع الأكواد السابقة فهدا سيوفي بالغرض بعد إظافة عنصر Label جديد بإسم Label15 لإظهار عدد السجلات كما في الصورة المرفقة Public WS As Worksheet Private Sub UserForm_Initialize() Set WS = Sheets("تسجيل البيانات") End Sub Private Sub Navigation(r As Integer) Dim NInvoice As String, tmp As Long, Col As Long NInvoice = Trim(TextBox8.Text) If NInvoice = "" Then MsgBox "يرجى إدخال رقم الفاتورة", vbExclamation Exit Sub End If tmp = TextBox8.Tag Col = FndRow(NInvoice, tmp, r) If Col = 0 Then MsgBox TextBox8.Value & " : " & "لا يوجد سجلات " & IIf(r = 1, "لاحقة", "سابقة") & _ " بنفس رقم الفاتورة", vbExclamation Else ContrArr Col End If End Sub Private Function FndRow(facture As String, c As Long, r As Integer) As Long Dim tmp As Long, lastRow As Long lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row If r = 1 Then For tmp = c + 1 To lastRow If WS.Cells(tmp, 1).Value = facture Then FndRow = tmp Exit Function End If Next tmp Else For tmp = c - 1 To 2 Step -1 If WS.Cells(tmp, 1).Value = facture Then FndRow = tmp Exit Function End If Next tmp End If FndRow = 0 End Function Private Sub ContrArr(tmp As Long) Dim n As Variant n = Array("TextBox7", "ComboBox1", "ComboBox2", "ComboBox3", "ComboBox4", _ "TextBox3", "TextBox4", "TextBox5", "TextBox6", "ComboBox5") If Me.TextBox8.Text = "" Then ClearControls Else Me.TextBox8.Tag = tmp For i = LBound(n) To UBound(n) Me.Controls(n(i)).Text = WS.Cells(tmp, i + 2).Value Next i tblUpdate tmp End If End Sub Private Sub SpinButton2_SpinDown() Navigation 1 End Sub Private Sub SpinButton2_SpinUp() Navigation -1 End Sub Private Sub résultats(facture As String) Dim Irow As Long Irow = ColRecherche(facture) If Irow = 0 Then MsgBox TextBox8.Value & " : " & "لا يوجد بيانات مطابقة لرقم الفاتورة", vbExclamation, "إنتـــباه" Me.TextBox8.Text = "" Label15.Caption = "السجل 1 من 1" Label15.Visible = False Else ContrArr Irow End If End Sub Private Function ColRecherche(facture As String) As Long Dim ColA As Range, cell As Range Set ColA = WS.Range("A2:A" & WS.Cells(WS.Rows.Count, 1).End(xlUp).Row) For Each cell In ColA If cell.Value = facture Then ColRecherche = cell.Row Exit Function End If Next cell ColRecherche = 0 End Function Private Sub ClearControls() Dim n As Variant n = Array("TextBox7", "ComboBox1", "ComboBox2", "ComboBox3", _ "ComboBox4", "TextBox3", "TextBox4", "TextBox5", "TextBox6", "ComboBox5") For i = LBound(n) To UBound(n) Me.Controls(n(i)).Text = "" Next i Me.TextBox8.Tag = "" Label15.Caption = "السجل 1 من 1" Label15.Visible = False End Sub Private Sub TextBox8_Change() If Me.TextBox8.Text = "" Then ClearControls Label15.Visible = False Exit Sub End If If Not IsNumeric(Me.TextBox8.Text) Then MsgBox "الرجاء إدخال قيمة رقمية فقط", vbExclamation Me.TextBox8.Text = "" ClearControls Exit Sub End If résultats Trim(TextBox8.Text) End Sub Private Sub tblUpdate(tblRow As Long) Dim facture As String, tblCount As Long, tmp As Long, lastRow As Long, tblMatch As Long facture = Trim(TextBox8.Text) lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row tblMatch = 0: tblCount = 0 For tmp = 2 To lastRow If WS.Cells(tmp, 1).Value = facture Then tblCount = tblCount + 1 If tmp = tblRow Then tblMatch = tblCount End If End If Next tmp Label15.Caption = "السجل " & tblMatch & " من " & tblCount Label15.Visible = True End Sub لقد قمت برفع ملفين: الأول بدون إظهار عدد السجلات والثاني يقوم بإظهارها يمكنك اختيار ما يناسبك بالتوفيق........... البحث والتنقل.rar

If Not Intersect(Target, Me.Range("I:L")) Is Nothing Then UnitsArr = Array("فدان", "قيراط", "سهم", "م²") With srcWS lastRow = .Columns("I:L").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If lastRow < 10 Then Exit Sub ColArr = .Range("I10:L" & lastRow).Value ReDim tmp(1 To lastRow - 9, 1 To 1) For i = 1 To UBound(ColArr, 1) tbl = "" For j = 4 To 1 Step -1 If IsNumeric(ColArr(i, j)) And ColArr(i, j) > 0 Then tbl = tbl & IIf(tbl <> "", " و ", "") & ColArr(i, j) & " " & UnitsArr(4 - j) End If Next j tmp(i, 1) = tbl Next i مساحة2.xlsb

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

وعليكم السلام ورحمة الله تعالى وبركاته بإستخدام الأكواد يمكنك تجربة هدا Private Sub Worksheet_Change(ByVal Target As Range) On Error GoTo ExitApp Application.EnableEvents = False Dim tmp() As Variant, ColArr As Variant, lastRow As Long, _ UnitsArr As Variant, i As Long, j As Integer, tbl As String Dim srcWS As Worksheet: Set srcWS = Me If Not Intersect(Target, Me.Range("I:L")) Is Nothing Then UnitsArr = Array("م²", "سهم", "قيراط", "فدان") With srcWS lastRow = .Columns("I:L").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If lastRow < 10 Then Exit Sub ColArr = .Range("I10:L" & lastRow).Value ReDim tmp(1 To lastRow - 9, 1 To 1) For i = 1 To UBound(ColArr, 1) tbl = "" For j = 1 To 4 If IsNumeric(ColArr(i, j)) And ColArr(i, j) > 0 Then tbl = tbl & IIf(tbl <> "", " و ", "") & ColArr(i, j) & " " & UnitsArr(j - 1) End If Next j tmp(i, 1) = tbl Next i With .Range("M10:M" & lastRow) .Value = tmp .ReadingOrder = xlRTL End With End With End If ExitApp: Application.EnableEvents = True End Sub مساحة.xlsb

For tmp = 6 To Irow If IsNumeric(SrcWS.Cells(tmp, "A").Value) Then SrcWS.Cells(tmp, "A").ClearContents End If Next tmp مطلوب ترقيم تلقائى لا يتأثر بحذف الصفوف.xlsb

هل تقصد حساب عدد الخلايا التي تحتوي على خليط من نصوص وأرقام مثلا 1م3 او T5 جرب هدا Option Explicit Function CalculerVal(rng As Range) As Long Dim cnt As Range, tmp As Long tmp = 0 For Each cnt In rng If cnt.Value <> "" Then If IsNumeric(cnt.Value) Or cnt.Value Like "*[0-9]*" Then tmp = tmp + 1 End If End If Next cnt CalculerVal = tmp End Function في الخلية التي تريد أن تظهر فيها النتيجة مع تعديلها بما يتناسب مع بياناتك الأصلية =CalculerVal(B2:H2) مجموع الأرقام مع الحروف.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Private Const Clé As String = "1234" ' قم بتعديل الباسوورد بما يناسبك Private Sub Worksheet_Change(ByVal Target As Range) Dim lastRow As Long lastRow = Cells(Rows.Count, "J").End(xlUp).Row ActiveSheet.Unprotect Clé If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing And Target.Columns.Count = 1 Then Application.EnableEvents = False Dim cell As Range For Each cell In Target If cell.Row >= 7 Then cell.Locked = Not IsEmpty(cell.Value) Next cell Application.EnableEvents = True End If ActiveSheet.Protect Clé, UserInterfaceOnly:=True End Sub '================================== Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim lastRow As Long, choose As String: Static OnRng As Range lastRow = Cells(Rows.Count, "J").End(xlUp).Row If Not Intersect(Target, Me.Range("J7:J" & lastRow)) Is Nothing Then If Not IsEmpty(Target.Value) Then If Target.Locked Then choose = InputBox(": خلية التوقيع محمية الرجاء إدخال كلمة المرور", ":إنتــباه") If choose = Clé Then ActiveSheet.Unprotect Clé If Not OnRng Is Nothing Then OnRng.Locked = True Target.Locked = False Set OnRng = Target ActiveSheet.Protect Clé, UserInterfaceOnly:=True ElseIf choose <> "" Then MsgBox "كلمة المرور غير صحيحة", vbExclamation, "خطأ" End If Else Set OnRng = Target End If Else ActiveSheet.Unprotect Clé Target.Locked = False Set OnRng = Nothing ActiveSheet.Protect Clé, UserInterfaceOnly:=True End If End If End Sub شيت حوافز تجريبى V2.xlsb

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

وعليكم السلام ورحمة الله تعالى وبركاته صراحة أخي @algammal التعامل مع الملف باستخدام المعادلات لتنفيذ طلبك غير عملي خصوصا أنك ترغب في إمكانية الترقيم التلقائي عند حذف أو إضافة صفوف جديدة أو حتى جدول جديد ما يزيد من التعقيد هو وجود العديد من الخلايا المدمجة والصفوف الفارغة على عمود الترقيم أعتقد أن الحل الأنسب هنا هو استخدام الأكواد مجرد إقتراح ربما يناسبك الكود التالي يعمل بشكل ديناميكي ويتعرف تلقائيا على الجداول بناءا على كلمات مفتاحية تحدد بداية الجدول ونهايته قمت بتحديدها نظرا لشكل تصميمك للملف حيث يقوم الكود بالبحث عن كلمة "الاسم" في عمود B للتعرف على بداية الجدول ومن ثم يبحث عن كلمة "المختص" في نفس العمود لتحديد نهاية الجدول وبمجرد تحديد نطاق الجدول سيقوم الكود بإعادة الترقيم على الجداول المتواجدة في الملف داخل هذا النطاق في العمود A بداية من الصف 7 إذا قمت بتغيير هذه الكلمات المفتاحية عليك تعديلها داخل الكود أيضا لذلك ييفضل أن تحرص دائما على وجود هذه الكلمات في أماكنها لتضمن عمل الكود بشكل صحيح Private Sub Worksheet_Change(ByVal Target As Range) Dim SrcWS As Worksheet, Irow As Long, tmp As Long, n As Long, OnRng As Long, tbl As Long, i As Long Const StarTBL As String = "الاسم" Const EndTBL As String = "المختص" On Error GoTo ErrorData Set SrcWS = Me Irow = SrcWS.Cells(SrcWS.Rows.Count, "B").End(xlUp).Row SetApp False For tmp = 6 To Irow If Not SrcWS.Cells(tmp, "A").MergeCells Then SrcWS.Cells(tmp, "A").ClearContents Next tmp n = 1 tmp = 6 Do While tmp <= Irow If Trim(SrcWS.Cells(tmp, "B").Value) = StarTBL Then OnRng = tmp + 1 Do While Trim(SrcWS.Cells(tmp, "B").Value) <> EndTBL And tmp <= Irow tmp = tmp + 1 Loop tbl = tmp - 3 For i = OnRng To tbl If Not SrcWS.Cells(i, "A").MergeCells And SrcWS.Cells(i, "A").Value = "" Then SrcWS.Cells(i, "A").Value = n n = n + 1 End If Next i End If tmp = tmp + 1 Loop SetApp True Exit Sub ErrorData: End Sub Private Sub SetApp(ByVal Enable As Boolean) Application.ScreenUpdating = Enable Application.EnableEvents = Enable Application.Calculation = IIf(Enable, xlCalculationAutomatic, xlCalculationManual) End Sub مطلوب ترقيم تلقائى لا يتأثر بحذف الصفوف.xlsb

Sub test() Dim wsSource As Worksheet, wsPass As Worksheet Dim lastRow As Long, i As Long, passRow As Long Set wsSource = Sheets("Sheet1") Set wsPass = Sheets("Sheet2") Application.ScreenUpdating = False Irow = wsPass.Cells(wsPass.Rows.Count, "G").End(xlUp).Row For j = 4 To Irow Step 2 wsPass.Range("A" & j & ":N" & j).ClearContents Next j lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row passRow = 4 For i = 3 To lastRow If InStr(1, LCase(wsSource.Cells(i, "G").Value), "1/6") > 0 Then wsPass.Cells(passRow, 1).Resize(1, 14).Value = wsSource.Cells(i, 1).Resize(1, 14).Value wsPass.Cells(passRow, 1).Value = passRow - 3 wsPass.Cells(passRow, 1).NumberFormat = wsSource.Cells(i, 1).NumberFormat passRow = passRow + 2 End If Next i Application.ScreenUpdating = True End Sub test.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته لست متأكدا مما تحاول فعله جرب هدا Sub test() Dim wsSource As Worksheet, wsPass As Worksheet Dim lastRow As Long, i As Long, passRow As Long, Rng As Range Set wsSource = Sheets("Sheet1") Set wsPass = Sheets("Sheet2") Application.ScreenUpdating = False lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row passRow = 4 For i = 3 To lastRow If InStr(1, LCase(wsSource.Cells(i, "G").Value), "1/6") > 0 Then wsPass.Cells(passRow, 1).Resize(1, 14).Value = wsSource.Cells(i, 1).Resize(1, 14).Value wsPass.Cells(passRow, 1).Value = passRow - 3 wsPass.Cells(passRow, 1).NumberFormat = wsSource.Cells(i, 1).NumberFormat passRow = passRow + 2 If Rng Is Nothing Then Set Rng = wsSource.Cells(i, 1).Resize(1, 14) If Not Rng Is Nothing Then Set Rng = Union(Rng, wsSource.Cells(i, 1).Resize(1, 14)) End If Next i If Not Rng Is Nothing Then Rng.ClearContents Application.ScreenUpdating = True End Sub لحدف الصفوف If Not Rng Is Nothing Then Rng.Delete Shift:=xlUp End If

وعليكم السلام ورحمة الله تعالى وبركاته لتحديد حجم كل منتج مع لونه يمكنك استخدام الصيغة التالية =SUMPRODUCT(($B$2:$B$8=$B11)*($C$2:$C$8=C$10)*($D$2:$J$8)) مع سحبها يسارا والى للاسفل على حسب احتياجاتك مجرد اقتراح يمكنك أيضا استخراج مجموع كل آلة بشكل منفصل حسب اختيارك للحصول على مزيد من التفاصيل وعند اختيار الخيار "الكل" سيتم عرض مجموع جميع الآلات يمكن القيام بذلك باستخدام الصيغة التالية بعد إضافة قائمة منسدلة تحتوي على أسماء رؤوس الأعمدة الموجودة في الجدول =IF($O$10="الكل", SUMPRODUCT(($B$2:$B$8=$M12)*($C$2:$C$8=N$11)*($D$2:$J$8)), IFERROR(SUMIFS(INDEX($D$2:$J$8, 0, MATCH($O$10, $D$1:$J$1, 0)), $B$2:$B$8, $M12, $C$2:$C$8, N$11), 0)) هدا سيمكنك من استخراج النتائج بعدة طرق يمكنك اختيار ما يناسبك زيرو 2.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك استخدام الكود التالي من المصنف الرئيسي وتحديث ملفات الإدارة دفعة واحدة بدون فتحها او تغيير تنسيقها يكفي وضعها في نفس مسار المصنف بحيث يتم تحديث البيانات عند التحقق من عدم وجود الرقم التأميني مسبقا على ملف الإدارة الهدف وتحديث عمود (م) وإظافة تاريخ التحديث في عمود ( تاريخ دخول القسم) Option Explicit Sub Departments_update() Dim WB As Workbook, destWB As Workbook, srcWS As Worksheet, destWS As Worksheet, _ iRow As Long, Rng As Range, dstRng As Long, lastRow As Long, Cnt As String, _ tmp As String, n As String, WSname As String, ShArr As Variant, j As Boolean, _ Updated As Boolean, nameFile As String, cell As Range, result As Boolean ShArr = Array("المستحقين", "احياء", "التفتيش", "اخرى") Cnt = "=SUBTOTAL(103,INDIRECT(ADDRESS(ROW(),COLUMN()+1)&"" :""&ADDRESS(ROW($E$7),COLUMN()+1)))" Updated = False result = False Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual Application.EnableEvents = False: Application.DisplayAlerts = False Set WB = ThisWorkbook For Each srcWS In WB.Worksheets If Not IsError(Application.Match(srcWS.Name, ShArr, 0)) Then WSname = srcWS.Name nameFile = WB.Path & "\" & WSname & ".xls" If Dir(nameFile) <> "" Then result = True Set destWB = Workbooks.Open(nameFile) Set destWS = destWB.Worksheets(WSname) If Not destWS Is Nothing Then For iRow = 7 To srcWS.Cells(srcWS.Rows.Count, "R").End(xlUp).Row n = srcWS.Cells(iRow, "R").Value If InStr(1, n, WSname, vbTextCompare) > 0 And n <> "" Then tmp = srcWS.Cells(iRow, "E").Value j = False lastRow = destWS.Cells(destWS.Rows.Count, "E").End(xlUp).Row For Each cell In destWS.Range("E7:E" & lastRow) If cell.Value = tmp Then j = True Exit For End If Next cell If Not j Then Set Rng = srcWS.Range(srcWS.Cells(iRow, 3), srcWS.Cells(iRow, 27)) dstRng = destWS.Cells(destWS.Rows.Count, "E").End(xlUp).Row + 1 If dstRng < 7 Then dstRng = 7 destWS.Cells(dstRng, "C").Resize(, 25).Value = Rng.Value destWS.Cells(dstRng, "D").Value = Date destWS.Cells(dstRng, "B").Formula = Cnt Updated = True End If End If Next iRow destWB.Close SaveChanges:=True Else destWB.Close SaveChanges:=False End If Set destWB = Nothing Set destWS = Nothing End If End If Next srcWS If result Then MsgBox IIf(Updated, "تم تحديث البيانات بنجاح", "جميع البيانات محدثة مسبقا"), vbInformation, "تعليمات" Else MsgBox "لم يتم العثور على أي ملفات خاصة بالإدارات", vbExclamation, "تنبيه" End If Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True: Application.DisplayAlerts = True Set WB = Nothing: Set srcWS = Nothing: Set Rng = Nothing: Set cell = Nothing End Sub ملفات الإدارة.rar ترحيل الصفوف مع عدم التكرار.rar