نجوم المشاركات

مشاركة مع الإخوة الأعزاء 🙂 هذه طريقتي في تضمين الخطوط في البرنامج .. 1- إرفاق الخطوط في البرنامج في جدول معد لذلك وبه حقل مرفقات : 2 - في الموديول كود يقوم باستخراج الخطوط ووضعها في مجلد بجانب قاعدة البيانات : 3 - يقوم الكود بتنصيب الخطوط تلقائيا بدون تدخل من المستخدم وذلك عن طريق الماكرو ( وبالمناسبة هو نفس الأمر الذي يستخرج الخطوط من الجدول ) 🙂 4- وبعدها ستجد أن الخطوط تعمل لديك بشكل جيد بدون مشاكل إن شاء الله 🙂 للتطبيق على برنامجك أنقل جميع العناصر لبرنامجك وغير الخطوط في الجدول . الملف : Add Fonts.accdb

بارك الله فيكم أساتذتى الكرام وجعل الله علمكم فى ميزان حسناتكم

مشاركة مع استاذي @ابوخليل Public Function RoundNmber(Rou As Double) As Double If Rou - Int(Rou) < 0.5 Then RoundNmber = Int(Rou) + 0.5 Else RoundNmber = Int(Rou) + 1 End If End Function

بعد اذن استاذ @Moosak ❤️🌹🌹 عدلة على مرفقك وزد ملفات ثانية بنفس الدالة شكرا على المرفق مع ضبط حجم النافذه لا يقل ويصغر فقط يتوسع ويكبر الى كامل الشاشة يمكن كان الحدث قبل التحديث ما ادري يمكن ينفع اجلب كافة الخطوط المستخدمة في القاعدة داخل الملف بجنب القاعده وداخل المرفقات بضغطة زر ولان الخطوط موجوده الا قليل ينفع اذا فقد الملف اعادة احضار الكل وعند التشغيل تقدر تضيف ملف ضغط رار فيه توزيعة ملفات = استخراج ثم فك الضغط كملفات على سبيل المثال PDF ( Book About Help ) له جدول يتصل بملفات جنب القاعده Public Function AddFonts() '======================================================( File Add Dim ExtractPath As String Dim FontPath As String Dim ExtractPath2 As String Dim FontPath2 As String Dim ExtractPath3 As String Dim FontPath3 As String Dim ExtractPath4 As String Dim FontPath4 As String Dim ExtractPath5 As String Dim FontPath5 As String Dim ExtractPath6 As String Dim FontPath6 As String Dim ExtractPath7 As String Dim FontPath7 As String Dim ExtractPath8 As String Dim FontPath8 As String Dim ExtractPath9 As String Dim FontPath9 As String Dim FSO As Scripting.FileSystemObject '======================================================( Exprt Fil In File Add Dim File As File Dim FontFolder As Folder Dim File2 As File Dim FontFolder2 As Folder Dim File3 As File Dim FontFolder3 As Folder Dim File4 As File Dim FontFolder4 As Folder Dim File5 As File Dim FontFolder5 As Folder Dim File6 As File Dim FontFolder6 As Folder Dim File7 As File Dim FontFolder7 As Folder Dim File8 As File Dim FontFolder8 As Folder Dim File9 As File Dim FontFolder9 As Folder Set FSO = New Scripting.FileSystemObject ' إنشاء مجلد للخطوط بجانب قاعدة البيانات '=========================================================( File 1 ExtractPath = CurrentProject.Path & "\fonts" If Not FSO.FolderExists(ExtractPath) Then FSO.CreateFolder (ExtractPath) '=========================================================( File 2 ExtractPath2 = CurrentProject.Path & "\Icon_Button" If Not FSO.FolderExists(ExtractPath2) Then FSO.CreateFolder (ExtractPath2) '=========================================================( File 3 ExtractPath3 = CurrentProject.Path & "\Icon_Msgbox" If Not FSO.FolderExists(ExtractPath3) Then FSO.CreateFolder (ExtractPath3) '=========================================================( File 4 ExtractPath4 = CurrentProject.Path & "\Sound" If Not FSO.FolderExists(ExtractPath4) Then FSO.CreateFolder (ExtractPath4) '=========================================================( File 5 ExtractPath5 = CurrentProject.Path & "\Wallpaper" If Not FSO.FolderExists(ExtractPath5) Then FSO.CreateFolder (ExtractPath5) '=========================================================( File 6 ExtractPath6 = CurrentProject.Path & "\Video" If Not FSO.FolderExists(ExtractPath6) Then FSO.CreateFolder (ExtractPath6) '=========================================================( File 7 ExtractPath7 = CurrentProject.Path & "\db_BE" If Not FSO.FolderExists(ExtractPath7) Then FSO.CreateFolder (ExtractPath7) '=========================================================( File 8 ExtractPath8 = CurrentProject.Path & "\ExE" If Not FSO.FolderExists(ExtractPath8) Then FSO.CreateFolder (ExtractPath8) '=========================================================( File 9 ExtractPath9 = CurrentProject.Path & "\IMG_Report" If Not FSO.FolderExists(ExtractPath9) Then FSO.CreateFolder (ExtractPath9) ' استخراج جميع الخطوط من الجدول إلى مجلد الخطوط '==========================================================( Form Name_tablet,File ,past File '==========================================================( 1 ExtractAllAttachments "FontsT", "Fonts", ExtractPath '==========================================================( 2 ExtractAllAttachments "FontsT", "Icon_Button", ExtractPath2 '==========================================================( 3 ExtractAllAttachments "FontsT", "Icon_Msgbox", ExtractPath3 '==========================================================( 4 ExtractAllAttachments "FontsT", "Sound", ExtractPath4 '==========================================================( 5 ExtractAllAttachments "FontsT", "Wallpaper", ExtractPath5 '==========================================================( 6 ExtractAllAttachments "FontsT", "Video", ExtractPath6 '==========================================================( 7 ExtractAllAttachments "FontsT", "db_BE", ExtractPath7 '==========================================================( 8 ExtractAllAttachments "FontsT", "ExE", ExtractPath8 '==========================================================( 9 ExtractAllAttachments "FontsT", "IMG_Report", ExtractPath9 '==========================================================( Chack File with Type For Past File '==========================================================( 1 Set FontFolder = FSO.GetFolder(ExtractPath) For Each File In FontFolder.Files If Right(File.Name, 3) = "TTF" Or Right(File.Name, 3) = "OTF" Then FontPath = ExtractPath & "\" & File.Name Debug.Print vbCr & FontPath AddOneFont FontPath Debug.Print File.Name, "Added" End If Next '==========================================================( 2 Set FontFolder2 = FSO.GetFolder(ExtractPath2) For Each File2 In FontFolder2.Files If Right(File2.Name, 3) = "TTF" Or Right(File2.Name, 3) = "OTF" Then FontPath2 = ExtractPath2 & "\" & File2.Name Debug.Print vbCr & FontPath2 AddOneFont FontPath2 Debug.Print File2.Name, "Added" End If Next '==========================================================( 3 Set FontFolder3 = FSO.GetFolder(ExtractPath3) For Each File3 In FontFolder3.Files If Right(File3.Name, 3) = "TTF" Or Right(File3.Name, 3) = "OTF" Then FontPath = ExtractPath3 & "\" & File3.Name Debug.Print vbCr & FontPath3 AddOneFont FontPath3 Debug.Print File3.Name, "Added" End If Next '==========================================================( 4 Set FontFolder4 = FSO.GetFolder(ExtractPath4) For Each File4 In FontFolder4.Files If Right(File4.Name, 3) = "TTF" Or Right(File4.Name, 3) = "OTF" Then FontPath = ExtractPath4 & "\" & File4.Name Debug.Print vbCr & FontPath4 AddOneFont FontPath4 Debug.Print File4.Name, "Added" End If Next '==========================================================( 5 Set FontFolder5 = FSO.GetFolder(ExtractPath5) For Each File In FontFolder5.Files If Right(File5.Name, 3) = "TTF" Or Right(File5.Name, 3) = "OTF" Then FontPath = ExtractPath5 & "\" & File5.Name Debug.Print vbCr & FontPath5 AddOneFont FontPath5 Debug.Print File5.Name, "Added" End If Next '==========================================================( 6 Set FontFolder6 = FSO.GetFolder(ExtractPath6) For Each File6 In FontFolder6.Files If Right(File6.Name, 3) = "TTF" Or Right(File6.Name, 3) = "OTF" Then FontPath6 = ExtractPath6 & "\" & File6.Name Debug.Print vbCr & FontPath6 AddOneFont FontPath6 Debug.Print File6.Name, "Added" End If Next '==========================================================( 7 Set FontFolder7 = FSO.GetFolder(ExtractPath7) For Each File7 In FontFolder7.Files If Right(File7.Name, 3) = "TTF" Or Right(File7.Name, 3) = "OTF" Then FontPath = ExtractPath7 & "\" & File7.Name Debug.Print vbCr & FontPath7 AddOneFont FontPath7 Debug.Print File7.Name, "Added" End If Next '==========================================================( 8 Set FontFolder8 = FSO.GetFolder(ExtractPath8) For Each File In FontFolder8.Files If Right(File8.Name, 3) = "TTF" Or Right(File8.Name, 3) = "OTF" Then FontPath8 = ExtractPath8 & "\" & File8.Name Debug.Print vbCr & FontPath8 AddOneFont FontPath8 Debug.Print File8.Name, "Added" End If Next '==========================================================( 9 Set FontFolder9 = FSO.GetFolder(ExtractPath9) For Each File In FontFolder9.Files If Right(File9.Name, 3) = "TTF" Or Right(File9.Name, 3) = "OTF" Then FontPath9 = ExtractPath9 & "\" & File9.Name Debug.Print vbCr & FontPath9 AddOneFont FontPath9 Debug.Print File9.Name, "Added" End If Next Set FSO = Nothing End Function SeT_File_SyS_Add_Pcage_And_Font_Ms_Access.rar

فعلا خطوط جميلة عاشت الايادي استاذ @Moosak

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

تأكد من تفعيل الوحدات النمطية والماكرو بالاكسس ثم اعادة التشغيل

وعليكم السلام ورحمة الله وبركاته تفضل test1.xlsx

في وحدة نمطية عامة الصق هذه الدالة Public Function RoundNmber(Rou As Double) As Double Dim i As Double i = Val(Rou) If i < CInt(i) Then i = CInt(i) ElseIf (i - CInt(i)) > 0 Then i = CInt(i) + 0.5 End If RoundNmber = i End Function تناديها من اي مكان في الاستعلام او النموذج او التقرير' =RoundNmber([yourText])

تفضل استاذنا @ابوخليل حسب مافهمت حفظ الصورة حسب الاختيار . Chose and Save Icon From Shell32.Dll.rar

جرب هذا ........................ Sub CleanAndRemovePatterns() Dim db As DAO.Database Dim rs As DAO.Recordset Dim strPattern As String Dim strInput As String Dim updatedText As String Dim regExp As Object On Error GoTo ErrorHandler Set db = CurrentDb Set rs = db.OpenRecordset("SELECT ID, nass FROM book", dbOpenDynaset) strPattern = "&\d+&&" Set regExp = CreateObject("VBScript.RegExp") regExp.Pattern = strPattern regExp.Global = True Do While Not rs.EOF If Not IsNull(rs!nass) Then strInput = rs!nass updatedText = strInput If regExp.Test(updatedText) Then updatedText = regExp.Replace(updatedText, "") End If If Left(updatedText, 2) = vbCrLf Then updatedText = Mid(updatedText, 3) ElseIf Left(updatedText, 1) = vbLf Then updatedText = Mid(updatedText, 2) ElseIf Left(updatedText, 1) = vbCr Then updatedText = Mid(updatedText, 2) End If updatedText = LTrim(updatedText) If strInput <> updatedText Then rs.Edit rs!nass = updatedText rs.Update End If End If rs.MoveNext Loop rs.Close Set rs = Nothing Set db = Nothing Set regExp = Nothing MsgBox "تمت إزالة الأنماط والسطر الفارغ بنجاح!", vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical If Not rs Is Nothing Then rs.Close Set rs = Nothing End If Set db = Nothing Set regExp = Nothing End Sub

السلام عليكم ورحمة الله وبركانه اظافة الى حل استاذنا احمد يوسف جزاه الله خيرا يمكن استخدام كود لاستدعاء اجور الطعام مع الاستحقاق مع اعتماد الخلايا الصفراء حال عدم وجود تاريخ معادلة بشروط1.xlsb

جرب واعلمنا ... لاني لم اجربه #If VBA7 Then Private Declare PtrSafe Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Const HWND_BROADCAST As LongPtr = &HFFFF& #Else Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Const HWND_BROADCAST As Long = &HFFFF& #End If Private Const WM_FONTCHANGE As Long = &H1D Sub InstallFonts() Dim dbPath As String Dim fontsFolder As String Dim fontFile As String Dim fontName As String Dim fso As Object Dim folder As Object Dim file As Object Dim fontInstalled As Boolean ' الحصول على مسار قاعدة البيانات ومجلد الخطوط dbPath = CurrentProject.Path fontsFolder = dbPath & "\الخطوط" ' التحقق إذا كان مجلد الخطوط موجودًا Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FolderExists(fontsFolder) Then MsgBox "مجلد الخطوط غير موجود: " & fontsFolder, vbExclamation Exit Sub End If ' تصفح الخطوط في المجلد Set folder = fso.GetFolder(fontsFolder) For Each file In folder.Files If LCase(Right(file.Name, 4)) = ".ttf" Or LCase(Right(file.Name, 4)) = ".otf" Then fontFile = file.Path fontName = GetFontName(fontFile) ' التحقق إذا كان الخط مثبتًا fontInstalled = IsFontInstalled(fontName) If Not fontInstalled Then If AddFontResource(fontFile) > 0 Then ' تحديث النظام لإضافة الخط SendMessage HWND_BROADCAST, WM_FONTCHANGE, 0, 0 MsgBox "تم تثبيت الخط: " & fontName, vbInformation Else MsgBox "فشل في تثبيت الخط: " & fontName, vbExclamation End If End If End If Next file MsgBox "اكتمل التحقق من الخطوط.", vbInformation End Sub Function IsFontInstalled(fontName As String) As Boolean Dim regPath As String Dim objRegistry As Object On Error Resume Next regPath = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts" Set objRegistry = CreateObject("WScript.Shell") IsFontInstalled = Not IsEmpty(objRegistry.RegRead(regPath & "\" & fontName & " (TrueType)")) On Error GoTo 0 End Function Function GetFontName(fontFile As String) As String ' استرجاع اسم الملف بدون الامتداد GetFontName = CreateObject("Scripting.FileSystemObject").GetBaseName(fontFile) End Function

وعليكم السلام يمكنك استخداد معادلة المصفوفة التالية (Ctrl+Shift+Enter) =INDEX(الاستحقاق!$D$2:$D$12,MATCH(1,IF($B2>=الاستحقاق!$B$2:$B$12,IF($B2<=الاستحقاق!$C$2:$C$12,IF($E2=الاستحقاق!$A$2:$A$12,1))),0)) معادلة بشروط1.xlsx

اسمحوا لي مشاركتكم ،، فقد أعجبت بالفكرة استناداً إلى ملف الأستاذ @Moosak ، وإن سمح لي بالتعديل عليه لتوليفه حسب حاجة أخونا @Mr-X التعديلات بسيطة الى حد ما ، ولكنها لبت المطلوب في المرفق التالي DBSize.accdb

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

وعليكم السلام ورحمة الله تعالى وبركاته ادا كنت قد إستوعبت طلبك بشكل صحيح فربما هدا سيوفي بالغرض ملاحظة : الملف يتضمن عدة أكواد يجب وضع كل كود في مكانه المناسب في Module1 ضع الأكواد التالية Const a As String = "الرئيسية" Const b As String = "تقرير بالموقع" Const c As String = "تقرير بالمنتج" Public Property Get WS() As Worksheet Set WS = Sheets(a) End Property Public Property Get dest() As Worksheet Set dest = Sheets(b) End Property Public Property Get dest2() As Worksheet Set dest2 = Sheets(c) End Property Sub Run_MainFilter() Call FilterData("J", dest, dest.Range("B2")) Call ApplyBorders(ActiveSheet) End Sub Sub Run_SecondaryFilter() Call FilterData("D", dest2, dest2.Range("B2")) Call ApplyBorders(ActiveSheet) End Sub ' دالة لفلترة البيانات Private Sub FilterData(srcColumn As String, srsWS As Worksheet, Clé As Range) Dim arr() As Variant, dataRange As Range, lastRow As Long Dim Crite As String, ColArr As Long, N As Long, lastCol As Long Crite = Clé.Value lastRow = WS.Cells(WS.Rows.Count, srcColumn).End(xlUp).Row If WS.Range(srcColumn & "3:" & srcColumn & lastRow).Find(Crite, _ LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then MsgBox Crite & " غير موجود", vbExclamation Exit Sub End If Application.ScreenUpdating = False srsWS.Range("A5:J" & srsWS.Rows.Count).ClearContents arr = WS.Range("A3:K" & WS.Cells(WS.Rows.Count, "I").End(xlUp).Row).Value N = 5 For ColArr = 1 To UBound(arr, 1) If arr(ColArr, WS.Range(srcColumn & "1").Column) = Crite Then srsWS.Cells(N, 1).Resize(1, 10).Value _ = Application.Index(arr, ColArr, Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11)) N = N + 1 End If Next ColArr lastCol = srsWS.Cells(5, srsWS.Columns.Count).End(xlToLeft).Column lastRow = srsWS.Cells(srsWS.Rows.Count, "A").End(xlUp).Row srsWS.PageSetup.PrintArea = srsWS.Range("A1", srsWS.Cells(lastRow, lastCol)).Address Application.ScreenUpdating = True End Sub ' تعبئة القائمة المنسدلة تقرير المنتج Sub AddDropdown_Main() Dim Data As Range, destCell As Range Dim lastRow As Long, OnRng As String OnRng = "Dropdown_Main" Set destCell = dest.Range("B2") lastRow = WS.Cells(WS.Rows.Count, "P").End(xlUp).Row Set Data = WS.Range("P2:P" & lastRow) On Error Resume Next ThisWorkbook.Names(OnRng).Delete On Error GoTo 0 ThisWorkbook.Names.Add Name:=OnRng, RefersTo:=Data With destCell.Validation .Delete .Add Type:=xlValidateList, Formula1:="=" & OnRng .IgnoreBlank = True .InCellDropdown = True End With End Sub ' تعبئة القائمة المنسدلة تفرير بالموقع Sub AddDropdown_Secondary() Dim Data As Range, destCell As Range Dim lastRow As Long, OnRng As String OnRng = "Dropdown_Secondary" Set destCell = dest2.Range("B2") lastRow = WS.Cells(WS.Rows.Count, "O").End(xlUp).Row Set Data = WS.Range("O2:O" & lastRow) On Error Resume Next ThisWorkbook.Names(OnRng).Delete On Error GoTo 0 ThisWorkbook.Names.Add Name:=OnRng, RefersTo:=Data With destCell.Validation .Delete .Add Type:=xlValidateList, Formula1:="=" & OnRng .IgnoreBlank = True .InCellDropdown = True End With End Sub ' تسطير البيانات Sub ApplyBorders(wsTarget As Worksheet) Dim lastRow As Long, rng As Range lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then Exit Sub Application.ScreenUpdating = False wsTarget.Range("A5:J100").Borders.LineStyle = xlNone Set rng = wsTarget.Range("A5:J" & lastRow) With rng.Borders .LineStyle = xlContinuous .Color = RGB(0, 0, 0) .Weight = xlThin End With Application.ScreenUpdating = True End Sub وفي حدث ورقة الرئيسية Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim tmp As Object, item As Range, OnRng As Range, ColArr As Range Dim LastRow As Long Application.ScreenUpdating = False If Not Intersect(Target, Me.Columns("D")) Is Nothing Or _ Not Intersect(Target, Me.Columns("J")) Is Nothing Then If Not Intersect(Target, Me.Columns("D")) Is Nothing Then Set ColArr = Me.Range("D3", Me.Cells(Me.Rows.Count, "D").End(xlUp)) Set OnRng = Me.Range("O2:O65000") Else Set ColArr = Me.Range("J3", Me.Cells(Me.Rows.Count, "J").End(xlUp)) Set OnRng = Me.Range("P2:P65000") End If Set tmp = CreateObject("Scripting.Dictionary") For Each item In ColArr If item.Value <> "" Then tmp(item.Value) = "" Next item OnRng.ClearContents If tmp.Count > 0 Then OnRng.Resize(tmp.Count, 1).Value = Application.Transpose(tmp.Keys) End If End If Application.ScreenUpdating = True End Sub في حدث ورقة تقرير بالموقع Private Sub CommandButton1_Click() Call SaveRangeAsPDF End Sub Private Sub Worksheet_Activate() Call AddDropdown_Secondary End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B2")) Is Nothing Then If Me.Range("B2").Value = "" Then _ MsgBox "برجاء إدخال إسم الموقع ", vbCritical: Exit Sub Call Run_SecondaryFilter End If End Sub وفي حدث ورقة تقرير بالمنتج Private Sub CommandButton1_Click() Call SaveRangeAsPDF End Sub Private Sub Worksheet_Activate() Call AddDropdown_Main End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Me.Range("B2")) Is Nothing Then If Me.Range("B2").Value = "" Then _ MsgBox "برجاء إدخال إسم المنتج ", vbCritical: Exit Sub Call Run_MainFilter End If End Sub وأخيرا في موديول جديد الكود الخاص بحفظ الملفات بصيغة PDF Option Explicit Sub SaveRangeAsPDF() Dim WSdest As Worksheet, sFile As String, folderName As String, sPath As String Dim lastRow As Long, lastCol As Long, pdfPath As String Set WSdest = ActiveSheet sFile = WSdest.Name folderName = "ملفات PDF" sPath = ThisWorkbook.Path & Application.PathSeparator & folderName & Application.PathSeparator On Error Resume Next If Len(Dir(sPath, vbDirectory)) = 0 Then MkDir sPath On Error GoTo 0 lastRow = WSdest.Cells(WSdest.Rows.Count, "A").End(xlUp).Row lastCol = WSdest.Cells(5, WSdest.Columns.Count).End(xlToLeft).Column WSdest.PageSetup.PrintArea = WSdest.Range("A1", WSdest.Cells(lastRow, lastCol)).Address With WSdest.PageSetup .Orientation = xlLandscape .PaperSize = xlPaperA4 .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1 End With pdfPath = sPath & sFile & ".pdf" WSdest.ExportAsFixedFormat Type:=xlTypePDF, fileName:=pdfPath, Quality:=xlQualityStandard MsgBox "تم حفظ الملف بنجاح", vbInformation End Sub بالتوفيق ............ جرد المنتج_V2.xlsb

السلام عليم اخي جرب المرفق Test.xlsm