محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته =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