محمد هشام.

اخي @هشام جمال الدين الملف المرفق عبارة عن شاشة دخول تتضمن تخويل صلاحية الدخول لاوراق معينة لمستخدم معين عبر تحديد دالك في ورقة صلاحيات باظافة عبارة نعم أو لا في الجدول التالي يمكنك اظافة ملفات أخرى للملف عادي سيتم تحديث أسمائها تلقائيا في عمود A بداية من الصف 6 دون مشاكل بما أنك حدفت جميع الأوراق السابقة والاحتفاظ فقط بالوقة 16 يكفي فقط تعديل الأكواد الخاصة بالدخول لأوراق العمل (مسميات الأوراق) لتفادي ظهور رسالة الخطأ معك أو مراجعة الموضوع الأصلي للتوضيح يمكنك إرفاق الملف المرغوب دمجه ربما نستطيع مساعدتك

وعليكم السلام ورحمة الله تعالى وبركاته حل اخر بإستخدام الأكواد Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim lastRow As Long, i As Long, n As Long, tmp As Variant, a As Object If Intersect(Target, Me.Columns("A:B")) Is Nothing Then Exit Sub Application.EnableEvents = False Application.ScreenUpdating = False On Error Resume Next lastRow = Me.Columns("A:B").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 If lastRow < 2 Then GoTo CleanUp Me.Range("A2:A" & lastRow).ClearContents tmp = Me.Range("B2:B" & lastRow).Value: Set a = CreateObject("Scripting.Dictionary") For i = 1 To UBound(tmp) If Len(Trim(tmp(i, 1))) > 0 And Not a.exists(tmp(i, 1)) Then n = n + 1: a(tmp(i, 1)) = n: Me.Cells(i + 1, "A").Value = n End If Next i CleanUp: Application.ScreenUpdating = True Application.EnableEvents = True End Sub ترقيم بتجاوز المكرر.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub FindStagnantItems() Const stagnantPeriod As Integer = 90 Dim WS As Worksheet, dest As Worksheet, ShArr As Variant, Ky As Object Dim lastRow As Long, i As Long, d As Object, cate As Variant, Irow As Long Dim item As String, Store As String, Movement As Date, C As Variant ShArr = Array("مخزن الرئيسي", "فرع 1") Set d = CreateObject("Scripting.Dictionary"): Set Ky = CreateObject("Scripting.Dictionary") For Each C In ShArr On Error Resume Next Set WS = ThisWorkbook.Sheets(C) On Error GoTo 0 If WS Is Nothing Then MsgBox "خطأ في الوصول إلى الورقة: " & C, vbCritical: Exit Sub Application.ScreenUpdating = False lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row For i = 2 To lastRow item = WS.Cells(i, 1).Value: Store = WS.Cells(i, 4).Value: Movement = WS.Cells(i, 3).Value If item <> "" And Store <> "" Then If IsDate(Movement) Then If DateDiff("d", Movement, Date) > stagnantPeriod Then If Not d.Exists(Store) Then d.Add Store, New Collection If Not n(d(Store), item) Then d(Store).Add item Ky(Store) = Ky(Store) + 1 End If End If End If Next i Next C On Error Resume Next: Set dest = Worksheets("أصناف راكدة"): On Error GoTo 0 If dest Is Nothing Then Set dest = Worksheets.Add: dest.Name = "أصناف راكدة" Else dest.Cells.ClearContents End If dest.[A1].Resize(1, 2) = Array("التصنيف", "عدد الأصناف الراكدة") Irow = 2 For Each cate In Ky.keys dest.Cells(Irow, 1).Value = cate dest.Cells(Irow, 2).Value = Ky(cate) Irow = Irow + 1 Next cate Application.ScreenUpdating = True MsgBox "تم إنشاء تقرير الأصناف الراكدة بنجاح", vbInformation End Sub Function n(col As Collection, val As String) As Boolean On Error Resume Next n = Not IsError(col(val)) End Function الاصناف الراكدة لكل مخزن.xlsm

يسعدنا أخي @محمد نوح أننا إستطعنا مساعدتك

أظن أنه يمكننا إضافة شرط التحقق من كلمة المرور عند محاولة غلق الحسابات في الكود بحيث لا يمكن لأي شخص تنفيذه إلا إذا كان يعرف كلمة المرور الصحيحة هذا يضيف طبقة أمان إضافية للحماية ويضمن أن الشخص الذي يقوم بالعملية هو الشخص المخول فقط جرب هدا التعديل Option Explicit Private Const Clé As String = "1234" Public Property Get WS() As Worksheet Set WS = Sheets("Sheet1") End Property Sub ProtectSheet(xligne As Long) With WS .Unprotect Password:=Clé: .Cells.Locked = False .Range("A2:M" & xligne).FormulaHidden = True .Range("A2:M" & xligne).Locked = True: .Protect Password:=Clé End With End Sub Sub WSUnprotect() With WS .Unprotect Password:=Clé .Cells.Locked = False .Cells.FormulaHidden = False End With End Sub Sub Data_Protection() Dim xligne As Long If InputBox("أدخل كلمة المرور للمتابعة") <> Clé Then MsgBox "كلمة المرور غير صحيحة تم إلغاء العملية", vbCritical Exit Sub End If xligne = Application.InputBox("أدخل رقم الصف الأخير لقفل الخلايا", Type:=1) If xligne < 1 Or xligne > WS.Rows.Count Then MsgBox "خطأ في الإدخال يرجى إدخال رقم صف صحيح", vbExclamation Exit Sub End If SetApp False ProtectSheet xligne SetApp True MsgBox "تم قفل الحسابات بنجاح لغاية الصف: " & xligne, vbInformation End Sub Sub Data_UnProtection() Dim PassProtect As String PassProtect = InputBox("أدخل كلمة المرور لفك الحماية") If PassProtect = Clé Then SetApp False: WSUnprotect: SetApp True MsgBox "تم فتح جميع الحسابات بنجاح", vbInformation ElseIf PassProtect <> "" Then MsgBox "كلمة المرور غير صحيحة", vbCritical End If End Sub Private Sub SetApp(ByVal enable As Boolean) On Error GoTo xError Application.ScreenUpdating = enable Application.EnableEvents = enable Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) Exit Sub xError: End Sub غلق المدى المحدد .xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا في Module ضع الكود التالي Sub ColoriageDoublons() Dim WSarr As Variant, couleurs As Long, d As Object, _ s As Variant, OnRng As Range, lastRow As Long, a, i As Long WSarr = Array(1, 2, 3): couleurs = RGB(0, 204, 255) Set d = CreateObject("Scripting.Dictionary") For Each s In WSarr With Sheets(s) lastRow = .Cells.Find(What:="*", LookIn:=xlValues, _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row a = .Range("C4:C" & lastRow).Value For i = 1 To UBound(a, 1) If a(i, 1) <> "" Then d(a(i, 1)) = d(a(i, 1)) + 1 Next i End With Next s For Each s In WSarr With Sheets(s) lastRow = .Cells.Find(What:="*", LookIn:=xlValues, _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set OnRng = .Range("C4:C" & lastRow) a = OnRng.Value For i = 1 To UBound(a, 1) OnRng.Cells(i).Interior.Color = IIf(a(i, 1) <> "" And d(a(i, 1)) > 1, couleurs, xlNone) Next i End With Next s End Sub وفي حدث ThisWorkbook Option Explicit Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim WSarr As Variant WSarr = Array("1", "2", "3") If Not Intersect(Target, Sh.Columns("C")) Is Nothing And Target.Row >= 4 Then Application.ScreenUpdating = False If Not IsError(Application.Match(Sh.Name, WSarr, 0)) Then Call ColoriageDoublons End If Application.ScreenUpdating = True End If End Sub تلوين الخلايا v2 المكررة.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Sub SaveAsPDF() Const Max As Long = 1000 Dim WS As Worksheet, Irow As Long, OnRng As Range Dim xPath As String, Dossier As String, Fichier As String Set WS = Sheets("Sheet1") Irow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row If Irow > Max Then Irow = Max: Set OnRng = WS.Range("A2:Z" & Irow) If Application.WorksheetFunction.CountA(OnRng) = 0 Then Exit Sub WS.ResetAllPageBreaks With WS.PageSetup .PrintArea = OnRng.Address: .Orientation = xlPortrait: .PaperSize = xlPaperA4 .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False End With Dossier = ThisWorkbook.Path & "\ملفات PDF" If Dir(Dossier, vbDirectory) = "" Then MkDir Dossier Fichier = Replace(WS.Range("AA1").Value, "/", "_") xPath = Dossier & "\" & Fichier & " " & Format(Now, "yyyy-mm-dd hh.mm") & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, FileName:=xPath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False WS.PageSetup.PrintArea = "" MsgBox "تم حفظ الملف بنجاح ", vbInformation End Sub Test-PDF.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Book1.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا حفظ الملفات في تفس مسار الملف Option Explicit Sub SAVE_PDF() Dim ScWS As Variant, Path As String, i As Integer ScWS = Array("Sheet1", "Sheet2", "Sheet3") Path = ThisWorkbook.Path & "\" If Path = "\" Then Exit Sub For i = LBound(ScWS) To UBound(ScWS) If Not ShExists(ScWS(i)) Then MsgBox "الورقة " & ScWS(i) & " غير موجودة": Exit Sub Application.ScreenUpdating = False On Error Resume Next Sheets(ScWS(i)).ExportAsFixedFormat Type:=xlTypePDF, FileName:=Path & ScWS(i) & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 Next i Application.ScreenUpdating = True MsgBox "تم حفظ الملفات بنجاح" End Sub لإنشاء مجلد وحفظ الملفات بداخله Sub SAVE_PDF_Folder() Dim ScWS As Variant, Path As String, Dossier As String, i As Integer ScWS = Array("Sheet1", "Sheet2", "Sheet3") Path = ThisWorkbook.Path & "\" Dossier = "ملفات PDF" If Path = "\" Then Exit Sub If Dir(Path & Dossier, vbDirectory) = "" Then MkDir Path & Dossier Path = Path & Dossier & "\" For i = LBound(ScWS) To UBound(ScWS) If Not ShExists(ScWS(i)) Then MsgBox "الورقة " & ScWS(i) & " غير موجودة": Exit Sub Application.ScreenUpdating = False On Error Resume Next Sheets(ScWS(i)).ExportAsFixedFormat Type:=xlTypePDF, FileName:=Path & ScWS(i) & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 Next i Application.ScreenUpdating = True MsgBox "تم حفظ الملفات بنجاح" End Sub Function ShExists(ByVal SheetName As String) As Boolean On Error Resume Next: ShExists = Not Sheets(SheetName) Is Nothing: On Error GoTo 0 End Function حفظ الملفات مستقلة بصيغة PDF.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub Transfer() Dim srcRange As Range, Lr As Long, destCols As Variant Dim WS As Worksheet, dest As Worksheet, i As Integer Dim a(1 To 1, 1 To 7) As Variant Set WS = ActiveSheet Set dest = Sheets("كشف الحساب") a(1, 1) = WS.[B6].Value: a(1, 2) = WS.[C6].Value: a(1, 3) = WS.[D6].Value a(1, 4) = WS.[E6].Value: a(1, 5) = WS.[G6].Value: a(1, 6) = WS.[H6].Value: a(1, 7) = WS.[I6].Value destCols = Array("C", "D", "E", "F", "H", "I", "J") Lr = dest.Cells(dest.Rows.Count, "D").End(xlUp).Row + 1 For i = 0 To 6 dest.Cells(Lr, destCols(i)).Value = a(1, i + 1) Next i End Sub """""""""""""""""""""""""""""""""""""""""""""""""""""""""" Sub testCopy() Dim i As Integer, ScrWS As Worksheet, btn As Object Dim Sh As Worksheet: Set Sh = Sheets("البون") Application.ScreenUpdating = False Application.DisplayAlerts = False Application.CutCopyMode = False For i = 1 To 15 On Error Resume Next Set ScrWS = ThisWorkbook.Sheets(Sh.Name & i) If Not ScrWS Is Nothing Then ScrWS.Delete Next i For i = 1 To 15 Sh.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) Set ScrWS = ActiveSheet ScrWS.Name = Sh.Name & i ScrWS.DisplayRightToLeft = True For Each btn In ScrWS.Buttons: btn.Delete: Next btn On Error GoTo 0 Set btn = ScrWS.Buttons.Add(400, 20, 60, 30): btn.OnAction = "Transfer": btn.Caption = "ترحيل" Next i Sh.Activate Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub الايرادات والمصروفات.xlsm

جرب هدا Private Sub Worksheet_Change(ByVal Target As Range) Dim Lr As Long Dim WS As Worksheet: Set WS = Sheets("فاتورة مبيعات") Lr = WS.Cells(WS.Rows.Count, "F").End(xlUp).Row Application.EnableEvents = False For Each tmp In Target If Not Intersect(tmp, WS.Columns("F")) Is Nothing Or Not Intersect(tmp, WS.Columns("E")) Is Nothing Then If tmp.Row <= Lr Then WS.Cells(tmp.Row, "G").Formula = "=IF(AND(F" & tmp.Row & "<>"""", E" & _ tmp.Row & "<>""""), F" & tmp.Row & "*E" & tmp.Row & ", """")" End If End If Next tmp Application.EnableEvents = True Exit Sub Application.EnableEvents = True End Sub او Private Sub Worksheet_Change(ByVal Target As Range) Dim ColArr As Long, a As Variant, i As Long Dim WS As Worksheet: Set WS = Me On Error GoTo SubApp Application.EnableEvents = False Application.Calculation = xlCalculationManual ColArr = WS.Columns("E:G").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row If Not Intersect(Target, WS.Range("E5:F" & ColArr)) Is Nothing Then a = WS.Range("E5:G" & ColArr).Value With WS For i = 1 To ColArr - 4 If IsNumeric(a(i, 1)) And IsNumeric(a(i, 2)) Then If Len(a(i, 1)) > 0 And Len(a(i, 2)) > 0 Then a(i, 3) = a(i, 1) * a(i, 2) Else a(i, 3) = "" End If Else a(i, 3) = "" End If Next i .Range("E5:G" & ColArr).Value = a End With End If SubApp: Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic End Sub طط.rar النتيجة قيم طط.rar

أخي @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