محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته =TEXT((A4-INT(A4))*1000,"000")

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا الخلية G2 ضع المعادلة التالية مع سحبها للأسفل =IFERROR(IF(G$6="قوى", IF(INDIRECT("'"&F$6&"'!L"&ROW()) <>"", INDIRECT("'"&F$6&"'!L"&ROW()), ""), IF(G$6="تامين", IF(INDIRECT("'"&F$6&"'!O"&ROW())<>"", INDIRECT("'"&F$6&"'!O"&ROW()), ""), "")),"") الخلية G2 =IFERROR(IF(G$6="قوى",IF(INDIRECT("'"&F$6&"'!M"&ROW()) <>"", INDIRECT("'"&F$6&"'!M"&ROW()), ""),IF(G$6="تامين", IF(INDIRECT("'"&F$6&"'!P"&ROW())<>"", INDIRECT("'"&F$6&"'!P"&ROW()), ""),"")),"") وفي خلية F6 ====> أسماء أوراق العمل يمكنك إتباع الخطوات التالية لجلب أسماء أوراق العمل للقائمة المنسدلة بشكل ديناميكي =OFFSET(F!$B$6, 0, 0, COUNTIF(F!$B$6:$B$10000, "<>"), 1) =NameWS BB.xlsx

جرب هدا في الخلية E2 = D2 - PRODUCT(C2, 10) أو =SUM(D2, -C2*10) المعدات v3.xlsx

لقد تم تعديل الكود في المشاركة السابقة لتتناسب مع طلبك يمكنك إعادة تحميل الملف من المرفقات مثال للنتائج المتوقعة :

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

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub Transfer() Dim code As Variant, c As Boolean Dim tmp(0 To 4) As Boolean, xDate As String, f As Long, i As Long, j As Long Dim lr As Long, lastRow As Long, linge As Long, xCode As Boolean, Irow As Range Dim ColArr As Long, xName As String, n As Variant, val As Variant Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") Dim Data As Worksheet: Set Data = Sheets("Sheet3") xDate = Format(CrWS.Range("D2").Value, "dd/mm/yyyy") If xDate = "" Then MsgBox "المرجوا تحديد التاريخ", vbInformation: Exit Sub With Data For ColArr = .Columns("E").Column To .Cells(3, .Columns.Count).End(xlToLeft).Column If Format(.Cells(3, ColArr).Value, "dd/mm/yyyy") = xDate Then f = ColArr: Exit For End If Next ColArr If f = 0 Then MsgBox "لم يتم العثور على التاريخ", vbExclamation: Exit Sub Set Irow = .Columns("E:P").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows) lr = IIf(Not Irow Is Nothing And Irow.row >= 5, Irow.row, 5) .Range(.Cells(5, f), .Cells(lr, f + 4)).ClearContents End With lastRow = CrWS.Cells(CrWS.Rows.Count, "C").End(xlUp).row xCode = False: c = False For i = 12 To lastRow code = CrWS.Cells(i, "C").Value If code <> "" Then linge = Data.Cells(Data.Rows.Count, "D").End(xlUp).row n = Application.Match(code, Data.Range("D6:D" & linge), 0) If Not IsError(n) Then xCode = True For j = 0 To 4 xName = CrWS.Cells(10, 4 + j).Value For ColArr = 0 To 4 If Data.Cells(4, f + ColArr).Value = xName Then val = CrWS.Cells(i, 4 + j).Value If Not IsEmpty(val) Then Data.Cells(n + 5, f + ColArr).Value = val c = True If Not tmp(j) Then Data.Cells(5, f + ColArr).Value = CrWS.Cells(11, 4 + j).Value tmp(j) = True End If End If Exit For End If Next ColArr Next j End If End If Next i Select Case True Case c MsgBox "تم ترحيل البيانات بنجاح", vbInformation Case Not xCode MsgBox "لم يتم العثور على أي أكواد مطابقة", vbExclamation Case Else MsgBox "لا توجد بيانات لترحيلها", vbInformation End Select End Sub Book3.xlsb

اسف لم أنتبه قمت بإظافة الرد على الموضوع بالخطأ المفروض الإستفسار كان لموضوع أخر على المنتدى

وعليكم السلام ورحمة الله تعالى وبركاته الخلية C2 عدد المعدات : =COUNTIFS(بينات!$D$3:$D$500, $A$2, بينات!$AS$3:$AS$500, $B$2) الخلية D2 عدد الساعات : =SUMIFS(بينات!$AN$3:$AN$500, بينات!$D$3:$D$500, $A$2, بينات!$AS$3:$AS$500, $B$2) التنسيق الشرطي إذا كانت الساعات أقل من 500 حدد الخلية D2 ثم ===== > Conditional Formatting ==> New Rule ==> Use a formula to determine which cells to format واكتب الصيغة التالية: =D2<500 المعدات v2.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته لاحظت أن الكود الخاص بك يسبب خطأ أثناء التنفيذ لأنه يحاول نسخ كامل النطاق المستخدم UsedRange من ملف book2 إلىbook1 بشكل مباشر وهذا يشمل الأزرار والأشكال وأي عناصر رسومية أخرى في الورقة مما يؤدي إلى توقف الكود أو ظهور أخطاء وبطء في الأداء بسبب كثرة العناصر المنسوخة لذلك أنصحك باستخدام الكود التالي الذي يعتمد على نسخ الصيغ والتنسيقات فقط عبر PasteSpecial مما يمنع نسخ العناصر غير المرغوب فيها ويضمن عمل الكود بسلاسة وبدون مشاكل Sub Button1_Click() Dim Wb1 As Workbook, Wb2 As Workbook, FilePath As String, OnRng As Range Dim WSdata As Worksheet, WSdest As Worksheet, WSname As String: WSname = "إدخال بيانات أساسية" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With Application.FileDialog(msoFileDialogFilePicker) .Title = "اختر ملف Excel كمصدر للبيانات" .Filters.Clear: .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsb" If .Show <> -1 Then MsgBox "لم يتم اختيار أي ملف", vbExclamation: Exit Sub FilePath = .SelectedItems(1) End With Set Wb1 = Workbooks.Open(FilePath) Set Wb2 = ThisWorkbook On Error Resume Next Set WSdata = Wb1.Sheets(WSname) Set WSdest = Wb2.Sheets(WSname) On Error GoTo 0 If WSdata Is Nothing Or WSdest Is Nothing Then MsgBox "لم يتم العثور على ورقة العمل", vbCritical Wb1.Close False Exit Sub End If Set OnRng = WSdata.UsedRange WSdest.Cells.UnMerge WSdest.Cells.ClearContents OnRng.Copy With WSdest.Range("A1") .PasteSpecial xlPasteFormulas .PasteSpecial xlPasteFormats End With Application.CutCopyMode = False Application.Goto WSdest.Range("A1"), True Wb1.Close False Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True MsgBox "تم نسخ البيانات بنجاح", vbInformation End Sub نسخ.rar

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Option Explicit Sub GetData() On Error GoTo EndClear Dim WS As Workbook, CrWS As Worksheet, dest As Worksheet, i As Long, tmp As Long Dim début As Long, tbl1 As Long, tbl2 As Long, ColArr As Variant, xPath As String ColArr = Split("1 2 3 4"): SetApp False Set dest = ThisWorkbook.Sheets("Sheet1"): xPath = ThisWorkbook.Path & "\aa.xlsb" If Dir(xPath) = "" Then MsgBox "الملف غير موجود: " & xPath, vbExclamation: GoTo CleanExit Set WS = Workbooks.Open(xPath) Set CrWS = WS.Sheets("Sheet1") If IsEmpty(dest.Cells(1, 1)) Then For i = 0 To UBound(ColArr) dest.Cells(1, i + 1).Value = CrWS.Cells(1, CLng(ColArr(i))).Value Next i End If début = 2: tbl1 = CrWS.Cells(CrWS.Rows.Count, "A").End(xlUp).Row: tmp = tbl1 - début + 1 If tmp <= 0 Then MsgBox "لا توجد بيانات للنسخ", vbExclamation: GoTo CleanExit tbl2 = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1 For i = 0 To UBound(ColArr) dest.Cells(tbl2, i + 1).Resize(tmp).Value = _ CrWS.Cells(début, CLng(ColArr(i))).Resize(tmp).Value Next i Application.Goto dest.Range("A1"), True CleanExit: If Not WS Is Nothing Then WS.Close False SetApp True If tmp > 0 Then MsgBox "تم ترحيل البيانات بنجاح", vbInformation Exit Sub EndClear: Resume CleanExit End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub ترحيل v2.rar

وعليكم السلام ورحمة الله وبركاته استكمالا لما تفضل به الأساتذة @Foksh و @hegazee من حلول مشكورة و إثراءا للموضوع أضع بين يديك اقتراحا إضافيا ربما قد يكون مناسبا لطلبك Private Sub Worksheet_Change(ByVal Target As Range) Const ColF As Long = 5, Irow As Long = 2, Max As Long = 5 Dim rng As Range, i As Long, ky() As String, Cnt$, tmp$, msg$, txt$ If Target.Column = ColF Then On Error GoTo Cleanup SetApp False For Each rng In Target txt = Trim(CStr(rng.Value)): msg = "" If txt = "" Then GoTo NextCell If InStr(txt, "/") > 0 Then msg = "(/) " & _ "خطأ: يرجى استخدام الشرطة العادية (-) بدلا من الشرطة المائلة" If msg = "" And InStr(txt, "-") = 0 Then msg = "خطأ: التنسيق غير صحيح" If msg = "" Then ky = Split(txt, "-") If UBound(ky) <> 1 Then msg = "خطأ: يجب أن يكون التنسيق بالشكل (رقم-رموز)" Else Cnt = ky(0): tmp = ky(1) If msg = "" And (Not IsNumeric(Cnt) Or Len(Cnt) < 1 Or Len(Cnt) > Irow) Then _ msg = "خطأ: الجزء الأول يجب أن يكون رقمًا مكونا من رقم أو رقمين فقط" If msg = "" And Len(tmp) > Max Then msg = "خطأ: الحد الأقصى للرموز بعد الشرطة هو 5 رموز" If msg = "" And Left(tmp, 1) = "0" Then msg = "خطأ: لا يسمح ببدء الجزء الثاني بصفر" For i = 1 To Len(tmp) - 1 If msg = "" And Mid(tmp, i, 1) Like "[A-Za-z]" And Mid(tmp, i + 1, 1) = "0" Then msg = "خطأ: لا يسمح بوجود صفر بعد الحرف الإنجليزي": Exit For End If Next i End If End If If msg <> "" Then MsgBox msg, vbCritical, "خطأ في إدخال رقم الحالة": rng.Value = "" NextCell: Next rng End If Cleanup: SetApp True End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub Book1 v2.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته بعد إدن أستادنا الفاضل @Foksh جرب إفراغ اليوزرفورم من جميع الأكواد السابقة ولصق الكود التالي ربما يناسبك Private Sub UserForm_Initialize() ComboBox1.Clear: Dim sh As Worksheet For Each sh In ThisWorkbook.Sheets: ComboBox1.AddItem sh.Name: Next ListBox1.ColumnCount = 3: ListBox1.ColumnWidths = "70;70;200" End Sub Private Sub ListBox1_Click() If ListBox1.ListIndex = -1 Then Exit Sub Dim ShName As String, Addr As String ShName = ListBox1.List(ListBox1.ListIndex, 0) Addr = ListBox1.List(ListBox1.ListIndex, 1) Sheets(ShName).Activate Sheets(ShName).Range("A4:F" & Sheets(ShName).Rows.Count).Interior.ColorIndex = xlNone With Sheets(ShName).Range("A" & Range(Addr).Row & ":F" & Range(Addr).Row) .Interior.Color = vbCyan: .Cells(1, 1).Activate End With TextBox2.Value = ListBox1.List(ListBox1.ListIndex, 2) End Sub Private Sub TextBox1_Change() On Error GoTo Cleanup SetApp False Dim ws As Worksheet, Sh_Name As String, ky As String, LastRow As Long, LastCol As Long Dim OnRng As Variant, i As Long, j As Long, xCount As Long, CellAddress As String Sh_Name = ComboBox1.Value ky = Trim(TextBox1.Text) If Sh_Name = "" Or ky = "" Then ListBox1.Clear Label5.Caption = "عدد النتائج: 0" If Sh_Name <> "" Then Sheets(Sh_Name).Range("A4:F" & _ Sheets(Sh_Name).Rows.Count).Interior.ColorIndex = xlNone Me.TextBox2 = "" GoTo Cleanup End If Set ws = Sheets(Sh_Name) With ws LastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row LastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column End With ListBox1.Clear ws.Range("A4:F" & ws.Rows.Count).Interior.ColorIndex = xlNone xCount = 0 OnRng = ws.Range(ws.Cells(4, 1), ws.Cells(LastRow, LastCol)).Value For i = 1 To UBound(OnRng, 1) For j = 1 To UBound(OnRng, 2) If InStr(1, OnRng(i, j), ky, vbTextCompare) > 0 Then xCount = xCount + 1 CellAddress = ws.Cells(i + 3, j).Address(False, False) ListBox1.AddItem Sh_Name ListBox1.List(ListBox1.ListCount - 1, 1) = CellAddress ListBox1.List(ListBox1.ListCount - 1, 2) = OnRng(i, j) ws.Range("A" & (i + 3) & ":F" & (i + 3)).Interior.Color = vbCyan Exit For End If Next j Next i Label5.Caption = "عدد النتائج: " & xCount Cleanup: SetApp True End Sub Private Sub UserForm_Terminate() Dim sh As Worksheet For Each sh In ThisWorkbook.Sheets sh.Range("A4:F" & sh.Rows.Count).Interior.ColorIndex = xlNone Next End Sub Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) TextBox1 = "": ListBox1.Clear End Sub Private Sub ComboBox1_Change() On Error Resume Next If ComboBox1.ListIndex = -1 Then Exit Sub TextBox1 = "": ListBox1.Clear Dim sh As Worksheet For Each sh In ThisWorkbook.Sheets sh.Range("A4:F" & sh.Rows.Count).Interior.ColorIndex = xlNone Next Sheets(ComboBox1.Value).Activate End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub ملاحظة :تم الاستغناء عن الكود Search_In_Sh() فأنت الآن لست بحاجة إليه بحث في عدة أوراق مع التحديد v2.xlsm

أخي @Hesham.Abusna نرجو منك التكرم بإرفاق نسخة من الملف الذي واجهت فيه المشكلة هدا سيساعدنا ذلك كثيرا على فحص هيكل الملف و المعادلات المستخدمة ولربما حجم البيانات ومن ثم تقديم الحل الأمثل بإذن الله كما يجب الإنتباه أنه في بعض الحالات قد يتسبب حجم المعادلات الكبير أو وجود أكواد معقدة أو حتى أوراق فارغة أو مخفية في اختلاف سلوك الكود لذلك فالمعاينة المباشرة ضرورية لتقديم دعم دقيق ومناسب و تشخيص المشكلة بدقة والوقوف على السبب الفعلي على العموم جرب الكود التالي على ملفك الأصلي ووافينا بالنتيجة Option Explicit Sub Sauvegarde_WB() Dim dossier$, chemin$, sFichier$, sPath$, sNom$ Dim WS As Worksheet, newWB As Workbook, newWs As Worksheet Dim n As Integer, data As Variant, OnRng As Range, _ shp As Shape, col As Long, rw As Long On Error GoTo EndClear SetApp False Set newWB = Workbooks.Add(xlWBATWorksheet) newWB.Sheets(1).Name = "Temp" n = 1 For Each WS In ThisWorkbook.Worksheets Set newWs = newWB.Sheets.Add(After:=newWB.Sheets(newWB.Sheets.Count)) sNom = Left(WS.Name, 31) Do While f(sNom, newWB) sNom = Left(WS.Name, 28) & "_" & n: n = n + 1 Loop newWs.Name = sNom Set OnRng = WS.UsedRange If OnRng.Cells.Count > 1 Then data = OnRng.Value newWs.Range("A1").Resize(UBound(data, 1), UBound(data, 2)).Value = data OnRng.Copy newWs.Range("A1").PasteSpecial xlPasteFormats Application.CutCopyMode = False For col = 1 To OnRng.Columns.Count newWs.Columns(col).ColumnWidth = WS.Columns(col).ColumnWidth Next col For rw = 1 To OnRng.Rows.Count newWs.Rows(rw).RowHeight = WS.Rows(rw).RowHeight Next rw Application.Goto newWs.Range("A1"), True End If On Error Resume Next For Each shp In newWs.Shapes If shp.Type = msoFormControl Or shp.Type = msoOLEControlObject Then shp.Delete Next shp On Error GoTo EndClear Next WS newWB.Sheets("Temp").Delete dossier = ThisWorkbook.Path & "\Workbook_Copy" If Dir(dossier, vbDirectory) = "" Then MkDir dossier sPath = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) sFichier = sPath & "_" & Format(Now, "dd-mm-yyyy_hh-nn-ss") & ".xlsx" chemin = dossier & "\" & sFichier newWB.Sheets(1).Activate newWB.SaveAs Filename:=chemin, FileFormat:=xlOpenXMLWorkbook newWB.Close False MsgBox "تم نسخ الملفات بنجاح", vbInformation SetApp True Exit Sub EndClear: SetApp True End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub Private Function f(sheetName As String, wb As Workbook) As Boolean Dim sht As Worksheet For Each sht In wb.Sheets If sht.Name = sheetName Then f = True: Exit Function Next sht f = False End Function إليك المرفق مرة أخرى بعد إظافة بعض المعادلات الجديدة للتجربة TEST v2.rar

لنجرب هذا مع إظافة الترتيب الأبجدي لعناصر الـكومبوبوكس عند النقر المزدوج يتم ترتيب القائمة تلقائيا قبل العرض Option Explicit Dim WS As Worksheet Dim OnRng As Variant Dim ColArr As Long Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set WS = Sheets("داتا") Dim f As Worksheet: Set f = Sheets("Sheet1") Dim lastRow As Long, cnt As Boolean, i As Long cnt = False lastRow = f.Cells(f.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow If Trim(f.Cells(i, "A").Value) <> "" Then cnt = True Exit For End If Next i 'A' إظهار القوائم لغاية أخر صف يتضمن تاريخ على عمود' If cnt Then If Target.Count = 1 And Not Intersect(Target, Range("C2:O" & lastRow)) Is Nothing Then ' OR ' C2:O100 تحديد اخر صف لإظهار القوائم يدويا بما يناسبك ' If Target.Count = 1 And Not Intersect(Target, Range("C2:O100")) Is Nothing Then ColArr = Target.Column If xColumn(ColArr) Then On Error Resume Next OnRng = WS.Range(WS.Cells(2, ColArr), _ WS.Cells(WS.Rows.Count, ColArr).End(xlUp)).Value On Error GoTo 0 If Not IsEmpty(OnRng) Then If Not IsArray(OnRng) Then ReDim OnRng(1 To 1, 1 To 1) OnRng(1, 1) = WS.Cells(2, ColArr).Value End If Me.ComboBox1.List = Application.Transpose(OnRng) Else Me.ComboBox1.List = Array() End If With Me.ComboBox1 .Height = Target.Height + 3 .Width = Target.Width .Top = Target.Top .Left = Target.Left .Value = Target.Value .Visible = True .Activate End With Else Me.ComboBox1.Visible = False End If Else Me.ComboBox1.Visible = False End If Else Me.ComboBox1.Visible = False End If End Sub Private Sub ComboBox1_Change() Dim d1 As Object Dim tmp As String Dim i As Long Set d1 = CreateObject("Scripting.Dictionary") If Me.ComboBox1.Value = "" Then Me.ComboBox1.List = Application.Transpose(OnRng) Me.ComboBox1.DropDown Else tmp = UCase(Me.ComboBox1.Value) & "*" For i = 1 To UBound(OnRng, 1) If UCase(Trim(OnRng(i, 1))) Like tmp Then d1(Trim(OnRng(i, 1))) = "" End If Next i If d1.Count > 0 Then Me.ComboBox1.List = d1.Keys Me.ComboBox1.DropDown Else Me.ComboBox1.List = Array(Me.ComboBox1.Value) Me.ComboBox1.DropDown End If End If ActiveCell.Value = Me.ComboBox1.Value End Sub Private Sub ComboBox1_Click() Me.ComboBox1.List = Application.Transpose(OnRng) Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub Private Function xColumn(colNum As Long) As Boolean Select Case colNum Case 3, 4, 5, 9, 10, 11, 15 xColumn = True Case Else xColumn = False End Select End Function Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then ActiveCell.Offset(1).Select End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) On Error Resume Next Dim listArr() As String, i As Long If Not IsEmpty(OnRng) Then ReDim listArr(1 To UBound(OnRng, 1)) For i = 1 To UBound(OnRng, 1) listArr(i) = OnRng(i, 1) Next i Call filtre(listArr) Me.ComboBox1.List = listArr End If Me.ComboBox1.Value = "" Me.ComboBox1.Activate Me.ComboBox1.DropDown On Error GoTo 0 End Sub Private Sub filtre(arr() As String) Dim i As Long, j As Long, temp As String, n As Long n = UBound(arr) For i = 1 To n - 1 For j = i + 1 To n If StrComp(arr(i), arr(j), vbTextCompare) > 0 Then temp = arr(i): arr(i) = arr(j): arr(j) = temp End If Next j Next i End Sub تعديل 4 .xlsb

وعليكم السلام ورحمة الله تعالى وبركاته أخي @sabah19672025 أعتقد أن طلبك غير واضح نوعا ما يمكن تنفيذ ذلك بعدة طرق حسب طريقة عملك واحتياجك ونحتاج فقط لتحديد الطريقة التي تفضل استخدامها: هل اختيار الملفات يدويا أي يتم عرض نافذة لتحديد ملفات PDF التي تريد نقلها (واحد أو أكثر) وسيقوم الكود تلقائيا بـإنشاء مجلد بنفس اسم كل ملف و نقل الملف إلى داخل هذا المجلد أم البحث داخل مجلد معين بحيث يتم تحديد مجلد يحتوي على الملفات المعنية و البحث داخله تلقائيا عن كل ملفات PDF مع إنشاء مجلد بنفس اسم كل ملف و نقل كل ملف إلى المجلد المناسب دفعة واحدة عموما إليك عدة إحتمالات يمكن إختيار ما يناسبك منها Sub test_MovePDF() Dim dl As FileDialog, selectedItems As Variant, fso As Object, i As Integer Dim xPath As String, xName As String, xFolder As String, newFolder As String Set dl = Application.FileDialog(msoFileDialogFilePicker) With dl .AllowMultiSelect = True .Title = "اختر ملفات PDF" .Filters.Clear .Filters.Add "PDF Files", "*.pdf" If .Show <> -1 Then MsgBox "لم يتم اختيار أي ملفات", vbExclamation Exit Sub End If Set fso = CreateObject("Scripting.FileSystemObject") For i = 1 To .selectedItems.Count xPath = .selectedItems(i) xName = fso.GetFileName(xPath) xFolder = fso.GetParentFolderName(xPath) newFolder = xFolder & "\" & Left(xName, Len(xName) - 4) If Not fso.FolderExists(newFolder) Then fso.CreateFolder newFolder End If Name xPath As newFolder & "\" & xName Next i End With MsgBox "تم نقل الملفات بنجاح", vbInformation End Sub '=================================== Sub Move_Selected_PDFs_To_Folders() Dim fso As Object, fd As FileDialog Dim i As Long Dim xPath As String, fileName As String, xFolder As String, newFolder As String Dim baseName As String Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Title = "اختر ملفات PDF المتفرقة" .Filters.Clear .Filters.Add "PDF Files", "*.pdf" .AllowMultiSelect = True If .Show <> -1 Then MsgBox "لم يتم اختيار أي ملفات", vbExclamation Exit Sub End If Set fso = CreateObject("Scripting.FileSystemObject") For i = 1 To .selectedItems.Count xPath = .selectedItems(i) fileName = fso.GetFileName(xPath) xFolder = fso.GetParentFolderName(xPath) baseName = fso.GetBaseName(fileName) newFolder = xFolder & Application.PathSeparator & baseName If Not fso.FolderExists(newFolder) Then fso.CreateFolder newFolder End If Name xPath As newFolder & Application.PathSeparator & fileName Next i End With MsgBox "تم نقل الملفات بنجاح", vbInformation End Sub '========================================= Sub test_Move_allPDF() Dim fso As Object, file As Object, newFolder As String Dim xFolder As String, xName As String, xPath As String With Application.FileDialog(msoFileDialogFolderPicker) .Title = "اختر المجلد الذي يحتوي على ملفات PDF" If .Show <> -1 Then Exit Sub xFolder = .selectedItems(1) End With Set fso = CreateObject("Scripting.FileSystemObject") For Each file In fso.GetFolder(xFolder).Files If LCase(fso.GetExtensionName(file.Name)) = "pdf" Then xName = fso.Getn(file.Name) xPath = file.Path newFolder = xFolder & Application.PathSeparator & xName If Not fso.FolderExists(newFolder) Then fso.CreateFolder newFolder End If Name xPath As newFolder & Application.PathSeparator & file.Name End If Next file MsgBox "تم نقل الملفات بنجاح", vbInformation End Sub تحويل الى ملفات v2.xlsm

أخي الكريم @زياد الحسناوي تحية طيبة هناك إستفسار بسيط فقط للتوضيح: هل المشكلة التي واجهتها تظهر فقط عند نقل المعادلة إلى ملفك الأصلي؟ أم أن الخطأ موجود أيضا في الملفات التي تم تحميلها من المنتدى؟ الهدف من هذا السؤال هو التحقق ما إذا كانت المشكلة ناتجة عن طريقة النقل أو التعديل على الملف الأصلي قبل الخوض في آخر توضيح لي ضمن هذا الموضوع أود أن أعتذر عن الخطأ غير المقصود في نسخ المعادلة الأخيرة داخل الرد في المداخلة السابقة رغم أنها كانت مكتوبة بشكل صحيح تماما داخل الملف المرفق المعادلة تعمل على البحث عن الأرقام المفقودة ضمن تسلسل يبدأ من أصغر رقم MIN(A:A) إلى أكبر رقم MAX(A:A) وترجع فقط الأرقام غير الموجودة فعليا في العمود A المعادلة الصحيحة =IFERROR(SMALL( IF(ISNA(MATCH(ROW(INDIRECT(MIN(A:A)&":"&MAX(A:A))), A:A, 0)), ROW(INDIRECT(MIN(A:A)&":"&MAX(A:A))) ), ROWS(C$1:C1)), "") أو =IFERROR(SMALL(IF(COUNTIF(A:A,ROW(INDIRECT(MIN(A:A)&":"&MAX(A:A)))) =0,ROW(INDIRECT(MIN(A:A)&":"&MAX(A:A)))),ROWS(D$1:D1)),"") أو بطريقة متقدمة نوعا ما =FILTER(SEQUENCE(MAX(A:A)-MIN(A:A)+1,1,MIN(A:A)), ISNA(MATCH(SEQUENCE(MAX(A:A)-MIN(A:A)+1,1,MIN(A:A)), A:A, 0))) أما بخصوص الحلول المقترحة تم تزويدك بعدة حلول مختلفة لتختار ما يناسب أسلوب عملك في الملف لأنك لم تحدد في سؤالك هل ترغب في عرض القيم المفقودة بشكل متسلسل دون فراغات؟ أم ترغب في عرضها بنفس مواقع الصفوف الأصلية (مع فراغات)؟ لذلك تم عرض كلا الإحتمالين ومن بينها المعادلة التي أشرت إليها تعرض القيم المفقودة مع وجود فراغات =IF(COUNTIF(A:A, ROW())=0, ROW(), "") مع تزويدك أيضا بمعادلة تعرض القيم المفقودة بشكل متسلسل دون فراغات =IFERROR( SMALL( IF(COUNTIF(A:A, ROW(INDIRECT("1:1900"))) = 0, ROW(INDIRECT("1:1900")) ), ROWS(J$1:J1) ), "") إذا كنت تريد إستخراج القيم المفقودة بناء على الحد الأدنى والحد الأعلى في العمود A بدون تحديد 1900 يدويا فقد تم التنبيه لدالك سابقا يمكنك تعديل ( 1:1900 ) حسب النطاق الذي تعمل عليه مثلا "1:"&MAX(A:A) ليتغير تلقائيا حسب البيانات =IFERROR( SMALL( IF(COUNTIF(A:A, ROW(INDIRECT(MIN(A:A)&":"&MAX(A:A)))) = 0, ROW(INDIRECT(MIN(A:A)&":"&MAX(A:A))) ), ROWS(J$1:J1) ), "") وبهذا ستكون بين يديك عدة اختيارات يمكنك تحديد ما يناسبك منها وفق الإصدار المستخدم لديك وشكل النتائج المتوقعة وهذه صورة توضح بياناتك بعد تصحيح المعادلات في الملف وتؤكد أنها تعمل كما هو متوقع ملاحظة أخيرة: يرجى التأكد من نسخ المعادلات كما هي دون تعديل أو حذف جزء منها مع مراعات تعديل عناوين الخلايا في حالة نسخها إلا عمود مختلف لأن أي خطأ بسيط في الصيغة قد يؤدي إلى عدم عملها بالشكل الصحيح وهذا ما تم ملاحظته في الملف الأخير المرفق من طرفك وأخيرا إدا كنت تستخدم إصدار حديث من الأوفيس فأفضل حل بالنسبة لك هو =FILTER(SEQUENCE(MAX(A:A)-MIN(A:A)+1,1,MIN(A:A)), ISNA(MATCH(SEQUENCE(MAX(A:A)-MIN(A:A)+1,1,MIN(A:A)), A:A, 0))) بالتوفيق.......... المصنف V2.xlsx

تفضل أخي ضع الكود التالي في حدث ورقة Sheet1 Option Explicit Dim OnRng As Variant Dim Cnt As Long Dim CrWS As Worksheet Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim dict As Object, lastRow As Long, i As Long, val As String, key As Variant, a As Variant On Error GoTo SupApp If Target.CountLarge > 1 Or Target.Row < 2 Or _ Target.Row > 100 Then ' '<==== هنا قم بتعديل اخر صف لاظهار القوائم بما يناسبك ComboBox1.Visible = False Exit Sub End If If ComboBox1 Is Nothing Then Exit Sub Set CrWS = ThisWorkbook.Sheets("داتا") If CrWS Is Nothing Then Exit Sub Cnt = Target.Column Select Case Cnt Case 3, 4, 5, 9, 10, 11, 15 lastRow = CrWS.Cells(CrWS.Rows.Count, Cnt).End(xlUp).Row If lastRow < 2 Then ComboBox1.Visible = False Exit Sub End If a = CrWS.Range(CrWS.Cells(2, Cnt), CrWS.Cells(lastRow, Cnt)).Value Set dict = CreateObject("Scripting.Dictionary") For i = 1 To UBound(a, 1) val = Trim(CStr(a(i, 1))) If val <> "" Then If Not dict.Exists(val) Then dict.Add val, Nothing End If End If Next i If dict.Count > 0 Then ReDim OnRng(1 To dict.Count, 1 To 1) i = 1 For Each key In dict.Keys OnRng(i, 1) = key i = i + 1 Next key Else ReDim OnRng(1 To 1, 1 To 1) OnRng(1, 1) = "" End If With ComboBox1 .List = Application.Transpose(OnRng) .Height = Target.Height + 3 .Width = Target.Width .Top = Target.Top .Left = Target.Left .Value = Target.Value .Visible = True .Activate End With Case Else ComboBox1.Visible = False End Select Exit Sub SupApp: ComboBox1.Visible = False End Sub Private Sub ComboBox1_Change() On Error Resume Next If Me.ComboBox1.Value <> "" Then Dim d1 As Object, i As Long Set d1 = CreateObject("Scripting.Dictionary") For i = 1 To UBound(OnRng, 1) If InStr(1, UCase(OnRng(i, 1)), UCase(Me.ComboBox1.Value), vbTextCompare) > 0 Then d1(OnRng(i, 1)) = "" End If Next i If d1.Count > 0 Then Me.ComboBox1.List = d1.Keys Me.ComboBox1.DropDown End If End If ActiveCell.Value = Me.ComboBox1.Value End Sub Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = vbKeyReturn Or KeyCode = vbKeyTab Then ActiveCell.Offset(1).Select ComboBox1.Visible = False KeyCode = 0 ElseIf KeyCode = vbKeyEscape Then ComboBox1.Visible = False KeyCode = 0 End If End Sub Private Sub ComboBox1_Click() On Error Resume Next If CrWS Is Nothing Then Exit Sub Dim lastRow As Long, xRng As Variant lastRow = CrWS.Cells(CrWS.Rows.Count, Cnt).End(xlUp).Row If lastRow < 2 Then Exit Sub xRng = CrWS.Range(CrWS.Cells(2, Cnt), CrWS.Cells(lastRow, Cnt)).Value If Not IsArray(xRng) Then ReDim tmp(1 To 1, 1 To 1) tmp(1, 1) = xRng xRng = tmp End If Me.ComboBox1.List = Application.Transpose(xRng) Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Me.ComboBox1.List = Application.Transpose(OnRng) Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub تعديل .xlsm

ببساطة أخي @زياد الحسناوي بعد إضافة الأرقام الجديدة لم تقم بسحب المعادلات للأسفل كما تمت الإشارة إليه في المشاركة السابقة وذلك لأنني قمت بوضع المعادلة على الملف المرفق بقدر البيانات الموجودة سابقا فقط هناك كدالك نقطة مهمة يجب الإنتباه إليها في المعادلة المقترحة =IFERROR(SMALL(IF(ISNA(MATCH(ROW(INDIRECT("1:" & MAX(A:A))), A:A, 0)), ROW(INDIRECT("1:" & MAX(A:A)))), ROWS(D$2:D2)), "") وظيفتها إظهار الأرقام المفقودة من تسلسل يبدأ من 1 حتى أكبر رقم موجود في العمود A وتعرض النتيجة في العمود D أو B حسب وضعها كما جاء في طلبك لكن هذه الصيغة تفترض أن الأرقام تبدأ من 1 وتتزايد بواحد مثال عندما تكون الأرقام بهذا الشكل مثلا فالصيغة أعلاه لن تعمل كما يجب لأنها تبدأ بالبحث من الرقم 1 بينما الأرقام الفعلية تبدأ من 15 لحل هذا الإشكال نقترح استخدام الصيغة التالية التي تعتمد على أصغر وأكبر رقم موجودين فعليا في العمود A =IFERROR(SMALL(IF(ISNA(MATCH(ROW(INDIRECT("1:" & MAX(A:A))), A:A, 0)), ROW(INDIRECT("1:" & MAX(A:A))) ), ROWS(D$2:D2)), "") المعادلة تبحث عن جميع الأرقام بين MIN و MAX وتستبعد الأرقام الموجودة فعليا في العمود A أي ترجع فقط الأرقام المفقودة في تسلسل منتظم وتعرض النتائج بشكل ديناميكي في العمود D بدءا من D2 ارقام مفقودة 3.xlsb

ارقام مفقودة 2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته الطريقة 1 : ضع المعادلة مثلا في B2 واسحب للأسفل: =IF(COUNTIF(A:A, ROW())=0, ROW(), "") الطريقة 2 : ضع المعادلة التالية مع استبدال الرقم 100 حسب الحد الأقصى في بياناتك ثم اسحب للأسفل: =IFERROR(SMALL(IF(COUNTIF(A:A,ROW(INDIRECT("1:100")))=0,ROW(INDIRECT("1:100"))),ROWS(B$1:B1)),"") أو بشكل ديناميكي =IFERROR(SMALL(IF(ISNA(MATCH(ROW(INDIRECT("1:" & MAX(A:A))), A:A, 0)), ROW(INDIRECT("1:" & MAX(A:A)))), ROWS(B$2:B2)), "") ادا كنت تستخدم نسخة حديثة من الأوفيس =LET( maxVal, MAX(A:A),fullSet, SEQUENCE(maxVal),missing, FILTER(fullSet, ISNA(MATCH(fullSet, A:A, 0))), IF(ROWS(B$2:B2)<=ROWS(missing), INDEX(missing, ROWS(B$2:B2)), "")) او بإستخدام الأكواد : يمكنك تعديل Max لتحديد الحد الأقصى الذي تبحث فيه عن الأرقام Option Explicit Sub RechercherNum() Dim lastRow As Long, i As Long, Max As Long Dim dict As Object, tmp As Long, col As String, a As Variant Dim WS As Worksheet: Set WS = Sheets("ورقة1") Set dict = CreateObject("Scripting.Dictionary") col = "G" ' عمود وضع القيم المفقودة Max = 100 ' الحد الأقصى المتوقع With Application .ScreenUpdating = False: .Calculation = xlCalculationManual: .EnableEvents = False WS.Range(col & "2:" & col & WS.Rows.Count).ClearContents lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row For i = 1 To lastRow a = WS.Cells(i, 1).Value If IsNumeric(a) Then dict(CLng(a)) = True Next i tmp = 2 For i = 1 To Max If Not dict.exists(i) Then WS.Cells(tmp, col).Value = i tmp = tmp + 1 End If Next i .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: .EnableEvents = True End With End Sub ارقام مفقودة.xlsb

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

وعليكم السلام ورحمة الله تعالى وبركاته Sub Sheets_Arrays3() Dim lr&, LR2&, WSData As Worksheet Dim Dest As Worksheet: Set Dest = Sheets("class_room") LR2 = Dest.Cells(Dest.Rows.Count, "B").End(xlUp).Row If LR2 >= 2 Then Dest.Range("B2:S" & LR2).ClearContents Application.ScreenUpdating = False For Each WSData In Sheets(Array("كي جي1", "كي جي2", _ "الصف الأول", "الصف الثاني", "الصف الثالث", "الصف الرابع", "الصف الخامس", "الصف السادس")) lr = WSData.Cells(WSData.Rows.Count, "B").End(xlUp).Row If lr >= 3 Then LR2 = Dest.Cells(Dest.Rows.Count, "B").End(xlUp).Row + 1 Dest.Range("B" & LR2 & ":S" & (LR2 + lr - 3)).Value = WSData.Range("B3:S" & lr).Value End If Next WSData Application.ScreenUpdating = True MsgBox "تم ترحيل الفرق بنجاح", vbInformation End Sub

وعليكم السلام ورحمة الله تعالى وبركاته هناك عدة حلول تعتمد على طريقة عملك منها استخدام USERPROFILE لجعل مسار الملف ديناميكيا _ وضع المصنف في نفس مجلد ملف الماكرو أو السماح للمستخدم باختيار الملف يدويا (Browse) كما أشار الأخ الفاضل @hegazee اليك الأكواد بالترتيب المدكور يمكنك إختيار ما يناسبك Sub OpenWorkbook1() Dim xPath As String, CrWS As Workbook On Error GoTo ErrHandler xPath = Environ("USERPROFILE") & "\Desktop\aa.xlsb" ' OR <===== aa.xlsx If Dir(xPath) = "" Then MsgBox "الملف غير موجود: " & xPath, vbExclamation: Exit Sub Set CrWS = Workbooks.Open(xPath) MsgBox "تم فتح الملف بنجاح", vbInformation Exit Sub ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub '=================================================== Sub OpenWorkbook2() Dim xPath As String, CrWS As Workbook On Error GoTo ErrHandler xPath = ThisWorkbook.Path & "\aa.xlsb" ' OR <===== aa.xlsx If Dir(xPath) = "" Then MsgBox " :الملف غير موجود" & vbNewLine & vbNewLine & xPath, vbExclamation: Exit Sub Set CrWS = Workbooks.Open(xPath) MsgBox "تم فتح الملف بنجاح", vbInformation Exit Sub ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub '================================================== Sub OpenWorkbook3() Dim xPath As String, CrWS As Workbook On Error GoTo ErrHandler xPath = Application.GetOpenFilename("إختيار الملف (*.xls*), *.xls*") If xPath = "False" Then MsgBox "تم إلغاء العملية", vbInformation: Exit Sub Set CrWS = Workbooks.Open(xPath) MsgBox "تم فتح الملف بنجاح: " & xPath, vbInformation Exit Sub ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub وفي حالة الرغبة في التحقق من أن إسم الملف الذي يختاره المستخدم يطابق إسم معين مثلا aa.xlsb قبل فتح الملف Sub OpenWorkbook4() Dim xPath$, CrWS As Workbook,Sname$ On Error GoTo ErrHandler Sname = "aa.xlsb" xPath = Application.GetOpenFilename("إختيار الملف (*.xls*), *.xls*") If xPath = "False" Then: MsgBox "تم إلغاء العملية", vbInformation: Exit Sub fileName = Dir(xPath) If StrComp(fileName, Sname, vbTextCompare) <> 0 Then MsgBox "اسم الملف غير مطابق" & vbNewLine & Sname, vbCritical Exit Sub End If Set CrWS = Workbooks.Open(xPath) MsgBox " :تم فتح الملف بنجاح" & vbNewLine & vbNewLine & CrWS.name, vbInformation Exit Sub ErrHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub bb.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته يمكنك تعديل هدا بما يناسبك Option Explicit Sub Sauvegarde_WB() Dim WS As Worksheet, CrWS As Workbook, newWs As Worksheet, f As Worksheet Dim chemin$, sNom$, dossier$, sPath$, n As Boolean On Error GoTo EndClear SetApp False Set CrWS = Workbooks.Add(xlWBATWorksheet) Set f = CrWS.Sheets(1): f.Name = "Temp" n = True For Each WS In ThisWorkbook.Worksheets WS.Copy After:=CrWS.Sheets(CrWS.Sheets.Count) Set newWs = CrWS.Sheets(CrWS.Sheets.Count) newWs.UsedRange.Value = newWs.UsedRange.Value On Error Resume Next: newWs.Buttons(1).Delete: On Error GoTo 0 newWs.Name = Left(WS.Name, 31) If n Then: f.Delete: n = False Next WS dossier = ThisWorkbook.Path & "\Workbook_Copy" If Dir(dossier, vbDirectory) = "" Then MkDir dossier sPath = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) sNom = sPath & "_" & Format(Now, "dd-mm-yyyy") & ".xlsx" chemin = dossier & "\" & sNom CrWS.SaveAs Filename:=chemin, FileFormat:=xlOpenXMLWorkbook CrWS.Close False SetApp True Exit Sub EndClear: SetApp True End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable: .EnableEvents = enable: .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub TEST.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد معاينة آخر مشاركاتك على المنتدى إليك الكود ليتوافق مع جميع الإصدارات سواءا 32bit أو 64bit جرب هدا ربما يناسبك Option Explicit #If VBA7 Then Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long #Else Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long #End If Private Const Style As Long = -16 Private Const Menu As Long = &H80000 Private Const MIN As Long = &H20000 Private Const MAX As Long = &H10000 Private Sub UserForm_Activate() Dim xForm As LongPtr, tmps As Long xForm = FindWindow("ThunderDFrame", Me.Caption) If xForm <> 0 Then tmps = GetWindowLong(xForm, Style) tmps = tmps Or Menu Or MIN Or MAX SetWindowLong xForm, Style, tmps DrawMenuBar xForm End If End Sub TEST Minimize.xlsb