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

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Sub مناداة_4() Dim wb As Workbook, wsData As Worksheet, wsDest As Worksheet Dim arr As Variant, k As Variant, Col As Variant, r As Long Set wb = ThisWorkbook: Set wsData = wb.Sheets("control4"): Set wsDest = wb.Sheets("مناداة4") arr = wsData.Range("C10:U" & wsData.Cells(Rows.Count, 6).End(xlUp).Row).Value2 Application.ScreenUpdating = False wsDest.Range("l5:W1000").ClearContents Col = Array(12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23) For Each k In Array(1, 3, 4, 8, 10, 11, 14, 15, 16, 17, 18, 19) wsDest.Cells(5, Col(r)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , k) r = r + 1 Next k Application.ScreenUpdating = True End Sub مصطفي - 2.xlsb

نعم يتم نسخ بيانات الأعمدة لغاية آخر قيمة على عمود الإسم يمكنك تعديلها بما يناسبك

تفضل اخي تم اظافة ورقة مخفية لعرض الملفات الموجودة داخل المجلد على الليست بوكس واستخراج وطباعة اسماء التقارير الغير مرفوعة 'Private Sub UserForm_Initialize() اظافة في nomPDF = "Tableau1" Réf = Range(nomPDF).Columns.Count List = Range(nomPDF).Resize(, Réf + 1).Value For i = 1 To UBound(List): Next i ''''''''''''''''''''''''''''''''' Private Sub Recherche_Change() ling1 = 1 ling2 = 2 clé = "*" & Me.Recherche & "*": n = 0 Dim Tbl() For i = 1 To UBound(List) On Error Resume Next If List(i, ling1) Like clé Or List(i, ling2) Like clé Then n = n + 1: ReDim Preserve Tbl(1 To 2, 1 To n) Tbl(1, n) = List(i, ling1): Tbl(2, n) = (Format((List(i, ling2)), "dd/mm/yyyy hh:mm")) End If Next i If n > 0 Then Me.ListBox1.Column = Tbl Else Me.ListBox1.Clear Counter = "عدد التقارير " & "/" & ListBox1.ListCount End Sub بالتوفيق.....🫡 الملف بعد التعديل 3.xls تقرير الحالات.rar

TEST.accdb

جرب البرنامج دة نظام مخازن .xlsm

اخي شايب كلامك صح مية بالمية وكان هو المطلوب بارك الله في اخي Foksh ساعدني بنسة كبيرة جدا من المطلوب ولكن كان طلبي مثل ما قلت تتم الفلتر من خلال حقول البحث ولكم جزيل الشكر و الامتنان

وعليكم السلام ورحمة الله وبركاته أنا ليس لدي دراية كافية بالـ VBA ولكن قد يحل هذا الكود الموضوع يمسح الخلايا الغير محمية في الورقة النشطة Sub ClearUnprotectedCells() Dim rng As Range Dim cell As Range Set rng = ActiveSheet.UsedRange For Each cell In rng If cell.Locked = False Then cell.ClearContents End If Next cell End Sub

تفضل الحل.xlsx

نقاط مهمة جدا ذكرها أستاذنا @شايب ، وكنت قد فكرت بها أثناء الرد ، ولكني توجهت لطلب الأخ فقط 😊

الحل.xlsx

اخي الكريم اذا بحثت ستجد الكثير من الموضيع التى تتحدث فى هذا الامر مثل https://cse.google.ae/cse?cx=partner-pub-4958585055085854:7791406915&ie=UTF-8&q=ربط+الاكسس+بجهاز+البصمه&sa=Search

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

السلام عليكم ورحمة الله تعالى وبركاته بارك الله فى اساتذتى الكرام كفو ووفو وما قصرو وزيادة فى الخير اضع حل بعد مواجهتى لمشكلة فى هذه النقطة عند التعامل مع ملفات الاكسل بسبب اختلاف النسخ والتسيق لملفات الاكسل تبعا لاختلاف الاصدارات اليكم الخطوات 1- انشاء وحدة نمطية عامة ليسهل استخدامها فى شتى زوايا التطبيق واعطها الاسم التالى basFileUtilityKit وضع بها هذا الكود ' Enumeration for the types of file dialogs Enum EnumFileDialogType msoFileDialogFilePicker = 1 msoFileDialogFolderPicker = 4 End Enum ' Enumeration for different file extensions Enum EnumFileExtensions AllFiles TextFiles ExcelFiles ImageFiles VideoFiles AudioFiles PDFFiles WordFiles ' You can add additional file extensions as needed here End Enum ' Enumeration for different options related to file paths Enum EnumOptionFile DirectoryWithoutFileName DirectoryWithFileName FileNameWithExtension FileNameWithoutExtension ExtensionOnly End Enum ' Function to open the folder dialog and return the selected folder path Function GetFolderDialog() As String On Error Resume Next Dim folderDialogObject As Object Set folderDialogObject = Application.FileDialog(EnumFileDialogType.msoFileDialogFolderPicker) With folderDialogObject .Title = "Select Folder" .AllowMultiSelect = False .Show End With If folderDialogObject.SelectedItems.Count > 0 Then GetFolderDialog = folderDialogObject.SelectedItems(1) Else ' Handle the case where no folder is selected MsgBox "No folder selected.", vbExclamation GetFolderDialog = "" End If Set folderDialogObject = Nothing On Error GoTo 0 End Function ' Function to open the file dialog and return the selected file path Function GetFileDialog(ByVal EnumFileExtension As EnumFileExtensions) As String On Error Resume Next ' Check if the Microsoft Office Object Library is referenced ' Make sure to go to Tools > References and select the appropriate version ' e.g., "Microsoft Office 16.0 Object Library" for Office 2016 Dim fileDialogObject As Object Set fileDialogObject = Application.FileDialog(EnumFileDialogType.msoFileDialogFilePicker) With fileDialogObject .Title = "Select File" .AllowMultiSelect = False .Filters.Clear ' Adding filters based on the selected file extension Select Case EnumFileExtension Case EnumFileExtensions.AllFiles .Filters.Add "All Files", "*.*" Case EnumFileExtensions.TextFiles .Filters.Add "Text Files", "*.txt" Case EnumFileExtensions.ExcelFiles .Filters.Add "Excel Files", "*.xlsx; *.xls" Case EnumFileExtensions.ImageFiles .Filters.Add "Image Files", "*.jpg; *.jpeg; *.png; *.gif" Case EnumFileExtensions.VideoFiles .Filters.Add "Video Files", "*.mp4; *.avi; *.mov" Case EnumFileExtensions.AudioFiles .Filters.Add "Audio Files", "*.mp3; *.wav; *.ogg" Case EnumFileExtensions.PDFFiles .Filters.Add "PDF Files", "*.pdf" Case EnumFileExtensions.WordFiles .Filters.Add "Word Files", "*.docx; *.doc" ' You can add additional file extensions as needed here End Select .Show End With If fileDialogObject.SelectedItems.Count > 0 Then GetFileDialog = fileDialogObject.SelectedItems(1) Else ' Handle the case where no file is selected MsgBox "No file selected.", vbExclamation GetFileDialog = "" End If Set fileDialogObject = Nothing Exit Function If Err.Number <> 0 Then Select Case Err.Number Case 3078: Resume Next ' Ignore error if user cancels the file dialog Case 0: Resume Next Case Else ' Call ErrorLog(Err.Number, Error$, strProcessName) End Select ' Clear the error Err.Clear End If End Function ' Function to get the desired option for a file path Function GetFileOption(ByRef strFilePath As String, Optional ByRef EnumOptionFile As EnumOptionFile = DirectoryWithFileName) As String On Error Resume Next Select Case EnumOptionFile Case DirectoryWithoutFileName GetFileOption = Left(strFilePath, InStrRev(strFilePath, "\")) Case DirectoryWithFileName GetFileOption = strFilePath Case FileNameWithExtension GetFileOption = Mid(strFilePath, InStrRev(strFilePath, "\") + 1) Case ExtensionOnly GetFileOption = Right(strFilePath, Len(strFilePath) - InStrRev(strFilePath, ".")) Case FileNameWithoutExtension GetFileOption = Mid(strFilePath, InStrRev(strFilePath, "\") + 1, InStrRev(strFilePath, ".") - InStrRev(strFilePath, "\") - 1) End Select On Error GoTo 0 End Function ' Function to get additional information about a file Function GetFileInfo(filePath As String) As String On Error Resume Next Dim fileInfo As String fileInfo = "File Information:" & vbCrLf fileInfo = fileInfo & "Path: " & filePath & vbCrLf fileInfo = fileInfo & "Size: " & FileLen(filePath) & " bytes" & vbCrLf fileInfo = fileInfo & "Created: " & FileDateTime(filePath) & vbCrLf GetFileInfo = fileInfo On Error GoTo 0 End Function 2- انشاء وحدة نمطية عامة ليسهل استخدامها فى شتى زوايا التطبيق واعطها الاسم التالى basExcelDataImport وضع بها هذا الكود Public Const strTableExcel As String = "tblImportExcel" Function ExcelDataImport(ByRef excelFilePath As String) On Error Resume Next ' Disable error handling temporarily Const xlOpenXMLWorkbook As Long = 51 ' Variables for Excel and Access Dim excelApp As Object Dim excelWorkbook As Object Dim excelOpened As Boolean Dim sourceFileName As String Dim mainDirectory As String Dim convertedExcelFilePath As String ' Check if the Excel file path is provided If Nz(excelFilePath, "") = "" Then Exit Function ' Check if the Excel file exists If Dir(excelFilePath) = "" Then Exit Function ' Extract file information sourceFileName = GetFileOption(excelFilePath, FileNameWithExtension) mainDirectory = GetFileOption(excelFilePath, DirectoryWithoutFileName) convertedExcelFilePath = excelFilePath ' Create Excel application object Set excelApp = CreateObject("Excel.Application") ' Check if Excel application is successfully created If Err.Number <> 0 Then Err.Clear Set excelApp = CreateObject("Excel.Application") excelOpened = False Else excelOpened = True End If ' Reset error handling On Error GoTo 0 ' Set Excel application visibility excelApp.Visible = False ' Open Excel workbook Set excelWorkbook = excelApp.Workbooks.Open(mainDirectory & sourceFileName) ' Save the workbook in xlsx format without displaying alerts excelApp.DisplayAlerts = False excelWorkbook.SaveAs Replace(mainDirectory & sourceFileName, ".xls", ".xlsx"), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False excelApp.DisplayAlerts = True ' Close the workbook without saving changes excelWorkbook.Close False ' Quit Excel application if it was opened by the function If excelOpened = True Then excelApp.Quit ' Update the source file name with the new extension sourceFileName = sourceFileName & "x" ' Reset file attributes SetAttr mainDirectory & sourceFileName, vbNormal ' Import Excel data into Access table DoCmd.SetWarnings False 'acSpreadsheetTypeExcel8 DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, strTableExcel, mainDirectory & sourceFileName, True ExitFunction: ' Enable system alerts before exiting the function DoCmd.SetWarnings True Exit Function ErrorHandler: ' Handle errors Select Case Err.Number Case 3078: Resume Next ' Ignore error if user cancels the file dialog Case 0: Resume Next Case Else ' Call ErrorLog(Err.Number, Error$, strProcessName) End Select End Function ' Function to delete all records from the specified table Sub DeleteAllRecords(Optional ByRef strTable As String = "") On Error Resume Next If Nz(strTable, "") = "" Then strTable = strTableExcel CurrentDb.Execute "DELETE FROM " & strTable ' Handle errors Select Case Err.Number Case 3078 If strTable = strTableExcel Then Resume Next Else Case Else ' HandleAndLogError strProcessName End Select End Sub 3- انشاء نموذج وفى الحدث عند النقر على زر الامر استخدم الكود التالى Private Sub cmdSubmit_Click() ' Get the path of the Excel file Dim strFilePath As String strFilePath = GetFileDialog(EnumFileExtensions.ExcelFiles) ' Check if a file was selected If strFilePath <> "Cancelled" Then ' Show status label Me!lblStatus.Visible = True Me!lblStatus.Caption = "Please wait ... " ' Clear TableData DeleteAllRecords ' Import data from Excel ExcelDataImport strFilePath ' Add Or Update Yor Table ' Hide the status label or reset any visual indicator Me!lblStatus.Visible = False Else ' User canceled the file selection MsgBox "File selection canceled", vbExclamation End If End Sub كل ما عليك الان يا صديقى العزيز شئ واحد عمل الاستعلام اللازم لاضاقة او تحديث وتعديل بياناتك طبقا لجدول الاكس حسب رغباتك وتطلعاتك واخيرا مرفق قاعدة البيانات ImportFromExel.accdb

مشاركة مع الاساتذه الكرام الاخ شايب يعتقد ان فكرة نموذج بحث التي اشار اليها الاساتذة فكرة معقولة ولكن يمكن التوصل للمطلوب بدون الحاجة الى ذلك حيث ان اخفاء او اظهار تبويب استبدال في نافذة البحث مرتبط بحالة التعديل للنموذج نعم او لا وبالتالي يمكن اضافة السطر Me.AllowEdits = False قبل الكود الذي تستخدمه ولكن لابد ان تعيد تغيير الخاصة الى نعم بعد تنفيذ البحث او في اي حدث اخر لتتمكن من تعديل البيانات في النموذج اخونا الشايب

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

أخى وأستاذى الفاضل ياسر خليل نورت الموضوع هذا الكود البسيط كفيل بتحقيق طلبات الأستاذ الميسانى الكود بيعمل pdf من النطاق المتاح وأنت تحدد مكان الحفظ فقط مع فتح الـــ pdf Sub PDFusingdialogbox() Dim Rng As Range Dim i As Variant Dim fName As String fName = ActiveSheet.[a1].Value i = Application.GetSaveAsFilename(fName, "PDF Files (*.pdf), *.pdf") Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6)) Application.ScreenUpdating = False Rng.Activate Selection.ExportAsFixedFormat Type:=xlTypePDF, FileName:=i, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True Sheets("ورقة1").Range("A1").Select Application.ScreenUpdating = True End Sub تحياتى كل سنة وأنتم أقرب الى الله هو فين صاحب الموضوع الأخ الكريم Creation !!!!!!!!!!!!!

الأخ الكريم Creation يرجى تغيير اسم الظهور للغة العربية الأخ الحبيب مختار بارك الله فيك وجزاك الله خير الجزاء الأخ الكريم الميساني .. إليك الكود بعد التعديل .. يمكنك من خلال الكود تعديل المسار واسم المللف كما يمكنك فتح الملف بعد التحويل من خلال آخر سطر تمت إضافة تعليقات على الأسطر التي يمكنك من خلالها التعديل Sub Convert_PDF() 'في مسار محدد من خلال الكود ثم فتح الملف [PDF] يقوم الكود بتحويل نطاق محدد إلى ملف '-------------------------------------------------------------------------------- On Error Resume Next Dim FileName As String, MyFileName As String, MS As String Dim Rng As Range If ActiveWindow.SelectedSheets.Count > 1 Then MsgBox "There is more then one sheet selected," & vbNewLine & "ungroup the sheets and try the macro again." Else On Error Resume Next '[PDF] تعيين النطاق المطلوب تحويله إلى Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6)) If Not Rng Is Nothing Then Debug.Print Rng.Address(External:=True) Rng.Select 'يمكن تغيير مسار الحفظ واسم الملف من خلال هذا السطر MyFileName = "C:\Users\" & Environ("UserName") & "\Desktop\" & ActiveSheet.[A1].Value FileName = Create_PDF(Selection, MyFileName, True, True) If FileName <> MyFileName Then MS = MsgBox("تم التحويل والحفظ بنجاح", vbInformation, "منظومة الصرافة") Else MS = MsgBox("قمت بإلغاء المهمة لذلك لم يتم التحويل", vbCritical, "منظومة الصرافة") End If End If End If 'بعد التحويل [PDF]سطر لفتح ملف الـ ActiveWorkbook.FollowHyperlink MyFileName & ".PDF" End Sub Function Create_PDF(Myvar As Object, FixedFilePathName As String, OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String Dim FileFormatstr As String Dim Fname As Variant If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _ & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then If FixedFilePathName = "" Then FileFormatstr = "PDF Files (*.jpeg), *.jpeg" Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _ Title:="Create PDF") If Fname = False Then Exit Function Else Fname = FixedFilePathName End If If OverwriteIfFileExist = False Then If Dir(Fname) <> "" Then Exit Function End If On Error Resume Next Myvar.ExportAsFixedFormat _ Type:=xlTypePDF, _ FileName:=Fname, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False On Error GoTo 0 If Dir(Fname) <> "" Then Create_PDF = Fname End If End Function كل عام وأنتم بخير