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

أتمنى أن تضيف بعضا من التوضيح : 1- موقع أي دولة و ما هو رابط الموقع إذا لم يكن هناك أي حرج 2- من أي ملف تريد نقل النتيجة أكسل أكسس...

السلام عليكم اخى الكريم تم ادراج بعض التحديثات على مرفقك وهى كالاتى 1 - تم ادراج وحدة نمطية لنقل الصور الى مجلد الصور 2 - تم ادراج وحدة نمطية لجلب مسارات الصور من كل فولدر يتم اختيارة ----------------------- يتم انشاء المجلدات الاتية تلقائيا فى نفس مسار قاعدة البيانات 1 - open backup --- وذلك لوضع اخر نسخة احتياطة عند الفتح 2 - close backup --- وذلك اخر نسخة احتياطية عند الاغلاق 3 - ادراج مجلد باسم الناريخ مع تغيير علامة / الى - وذلك لاستحالة انشاء مجلد يحمل تلك العلامة ------------------------------------- تم ادراج كائن واحد داخل النموذج وهى ( Listbox ) وذلك لاحضار مسارات الصور بها واصبح شكل مرفقك كالتالى ------------------------ تم ادراج دالة لجلب الاسم والنوع للصورة عند اختيارها وهى كالتالى Function GetFilenameFromPath1(ByVal strPath As String) As String If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then GetFilenameFromPath1 = GetFilenameFromPath1(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1) End If End Function الية العمل كما طلبت اخى الكريم 1 - يتم انشاء نسخة احتياطية عند الفتح وعند الاغلاق فى مجلدين منفصلين فى نفس مسار قاعدة البيانات وهذا هو الكود الخاص بهما مع تغيير اسم الملف فقط فى الحالتين Dim OldFile, DBwithEXT, DBwithoutEXT, NewFile, CopyMyDB OldFile = CurrentDb.Name DBwithEXT = Dir(OldFile) DBwithoutEXT = Left(DBwithEXT, Len(DBwithEXT) - 4) NewFile = CurrentProject.Path & "\" & "open backup" & "\" & DBwithoutEXT & Right(DBwithEXT, 4) CopyMyDB = "cmd.exe /C copy " & """" & OldFile & """" & " " & """" & NewFile & """" Shell CopyMyDB, 0 MyErr: If err.Number <> 0 Then MsgBox err.Number & " - " & err.Description وحدة نمطية لجلب الملفات من مجلد محدد الى Listbox Public Function ListFiles(strPath As String, Optional strFileSpec As String, _ Optional bIncludeSubfolders As Boolean, Optional lst As ListBox) On Error GoTo Err_Handler 'Purpose: List the files in the path. 'Arguments: strPath = the path to search. ' strFileSpec = "*.*" unless you specify differently. ' bIncludeSubfolders: If True, returns results from subdirectories of strPath as well. ' lst: if you pass in a list box, items are added to it. If not, files are listed to immediate window. ' The list box must have its Row Source Type property set to Value List. 'Method: FilDir() adds items to a collection, calling itself recursively for subfolders. Dim colDirList As New Collection Dim varItem As Variant Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders) 'Add the files to a list box if one was passed in. Otherwise list to the Immediate Window. If lst Is Nothing Then For Each varItem In colDirList Debug.Print varItem Next Else For Each varItem In colDirList lst.AddItem varItem Next End If Exit_Handler: Exit Function Err_Handler: MsgBox "Error " & err.Number & ": " & err.Description Resume Exit_Handler End Function Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _ bIncludeSubfolders As Boolean) 'Build up a list of files, and then add add to this list, any additional folders Dim strTemp As String Dim colFolders As New Collection Dim vFolderName As Variant 'Add the files to the folder. strFolder = TrailingSlash(strFolder) strTemp = Dir(strFolder & strFileSpec) Do While strTemp <> vbNullString colDirList.add strFolder & strTemp strTemp = Dir Loop If bIncludeSubfolders Then 'Build collection of additional subfolders. strTemp = Dir(strFolder, vbDirectory) Do While strTemp <> vbNullString If (strTemp <> ".") And (strTemp <> "..") Then If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then colFolders.add strTemp End If End If strTemp = Dir Loop 'Call function recursively for each subfolder. For Each vFolderName In colFolders Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True) Next vFolderName End If End Function Public Function TrailingSlash(varIn As Variant) As String If Len(varIn) > 0& Then If Right(varIn, 1&) = "\" Then TrailingSlash = varIn Else TrailingSlash = varIn & "\" End If End If End Function بعد كتابة التاريخ وعند اختيار صورة يتم نقلها الى مجلد التاريخ بنفس اسمها وعند التنقل بين السجلات بواسطة الازرار يتم عمل قائمة باسماء الملفات الموجودة داخل كل مجلد الذى يحمل التاريخ يمكنك اضافة اكثر من صورة للتاريخ الواحد ولكن كل منهما على حدا وهذا فيديو يشرح العمل وهذا هو المرفق PIC.rar

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

بارك الله فيك والحمد لله الذى بنعمته تتم الصالحات

الحمد لله لى على هذه المشاركة Book1.xlsx

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

لك ما طلبت اخى الكريم مثال.xlsx

تفضل اخى الكريم لك ما طلبت الملف جاهز على الإستخدام عليك بإدخال ما تشاء من اسماء العملاء والمعتمرين فى المكان المخصص لهما فى الصفحة المفتوحة جديدا وهى Setting وذلك لكى يتم اختيار الأسماء بعد ذلمك من القائمة الموجودة فى شيت ادخال البيانات لديك وفى شيت الإدخال بعد اختيار اسم العميل واسم المعتمر عليك بعد ذلك كتابة رقم جواز السفر لهذا المعتمر ثم بكتابتك الرقم القومى له فسوف يظهر لك باقى الأعمدة بدون تدخل منك فقط بالمعادلات فعليك فقط فى اخر عمود ادخال رقم التليفون وشكرا لك وبارك الله فيك واتمنى ان يكون الأمر الأن بسيطا لك شرفتنا فى المنتدى Book1.xlsm

وعليكم السلام لابد من رفع الملف للعمل عليه لكى تتم المساعدة

السلام عليكم ورحمة الله تعالى وبركاته اخى الكريم قمت ببعض التعديلات على جدول الاصناف فقط قمت بالغاء حقل مسار الصورة وغيرته الى امتداد الصورة الية العمل الجديدة للبرنامج ستكون كالتالى اولا يجب تحديد مسار مجلد الصور الموجود على جوجل درايف لكل مستخدم للبرنامج قمت بتسهيل الموضوع عليك فقط مرة واحدة اختر المسار عن طريق هذا الزر وعند اختيارك المجلد يقوم البرنامج باخذ المسار واسم الكمبيوتر الخاص بك وادراجهم داخل جدول قمت بانشائه عند اختيارك صورة يقوم البرنامج جلب نوع الصورة وادراجها فى جدول الاصناف ثم نقلها الى مجلد الصور برقم الصنف اى انه يتم تسمية الصورة برقم الصنف الاكواد المستخدمة دالة جلب نوع الصورة عند اختيارها Function GetFileTypeFromPath(ByVal strPath As String) As String If Right$(strPath, 1) <> "." And Len(strPath) > 0 Then GetFileTypeFromPath = GetFileTypeFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1) End If End Function داالة جلب اسم الكمبيوتر الحالى للمستخدم Declare Function apiGetUserName Lib "advapi32" Alias "GetUserNameA" (ByVal buffer As String, BufferSize As Long) As Long Declare Function apiGetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal buffer As String, BufferSize As Long) As Long Function GetUserName() As String Dim strName As String Dim lngSize As Long Dim lngRetVal As Long strName = Space(15) lngSize = 15 lngRetVal = apiGetUserName(strName, lngSize) GetUserName = Left$(strName, lngSize - 1) End Function Function GetComputerName() As String Dim strName As String Dim lngSize As Long strName = Space(16) lngSize = 16 If apiGetComputerName(strName, lngSize) Then GetComputerName = Left$(strName, lngSize) Else GetComputerName = vbNullString End If End Function دالة نقل الملفات 'Network Security - Network does not allow reference to the Scripting runtime library (COM Object) ' Using Window 32 API (Kernel 132) to Move file Private Declare Function CopyFileA Lib "kernel32" (ByVal ExistingFileName As String, _ ByVal NewFileName As String, ByVal FailIfExists As Long) As Long Public Function Copy(FileSrc As String, FileDst As String, Optional NoOverWrite As Boolean = True) As Boolean Dim Flag As Long Dim Name As String Name = Right(FileSrc, Len(FileSrc) - InStrRev(FileSrc, "\")) If CopyFileA(FileSrc, FileDst & Name, NoOverWrite) Then Copy = True Else Copy = False End If End Function ويتم تنفيذها بهذا الشكل Dim sedo As Object Dim des, fileto As String Set sedo = CreateObject("Scripting.FileSystemObject") sedo.CopyFile fileto, des, True حيث ان fileto هو الملف المراد نقله يتم تحديد المسار كاملا بما فى ذلك نوع الملف حيث ان des هو المسار المراد نقل الملف اليه ويتم تحديد المسار كاملا ايضا بما فى ذلك نوع الملف هكذا "des = "C:\Users\xmen5\Desktop\New Microsoft Word Document (2).docx و "fileto = "C:\Users\xmen5\Desktop\New Microsoft Word Document (2).docx ويمكن تغير اسم الملف فقط فى متغير des ليتم نقل الملف باسم جديد تم تغيير مصدر بيانات عنصر تحكم الصورة ليتمكن من قراءة مسار الصورة هكذا وهذا كود انشاء مجلد جديد فى مسار محدد لاخونا السائل If Len(Dir(des, vbDirectory)) = 0 Then MkDir Path:=des end if حيث ان des هى مسار المجلد تذكر يا اخى يجب تحديد مسار مجلد الصور اولا ولمرة واحدة لكل مستخدم للبرنامج والان مع المرفق http://www.mediafire.com/file/t6pv4pg7iz9feg6/ACC.rar/file

استاذ علي انتبهت الى هذا الخطأ متأخراً وقد تم التصحيح في نفس المشاركة اذا لاحظت ذلك

انها حقا معادلة رائعة استاذى الكريم -ولكنى اعتقد ان تكون هكذا لكى يتم اضافة 3 أشهر , فعندما تم تطبيق معادلة حضرتك اعطت التاريخ فى الخلية A2 -01/07/2019 فلابد ان يكون 01/04/2019 =DATE(YEAR($A$1),MONTH($A$1)+3*(ROWS($A$1:A1)),1)

ربما تنفع هذه المعادلة =DATE(YEAR($A$1),MONTH($A$1)+3*(ROWS($A$1:A1)),1)

اذا تابع الموضوع هنا سادرج الاكواد ان شاء الله لاحقا مع شرحها

تفضل مع مقارنة عمودين مع بعضهما(1).xlsm

اشكرك اخي ✔️@ابو حمزة سكر معلومات قيمة ومفيدة

أحسن الله إليك كما ذكرت أخي ليس هناك أفضلية لإعادة الضغط علي الزر إلا في إعادة تغير الألوان والترتيب فقط. المهم الآن أن ييسر الله لنا من خلال قيام أحد من الأخوة الخبراء الكبار أصحاب العلم والفكر والإبداع المميز بإنهاء المطلوب في أقرب وقت بإذن الله ؟؟!! أعتقد أن موضوع حصر نتائج التكرار او التشابه غير المتماثل يستحق بعض الوقت والجهد لتطويره للوصول لأفضل نتيجة فلقد بحثت ولم أجد له نتائج

أهلا بك اخى الكريم فى المنتدى تفضل لك ما طلبت بمعادلات المصفوفة مثال.xlsx

تفضل أخى أحمد يوسف أخى عمر ضاحى هذه الأكواد محاولات لتنفيذ طلبك لينك الذهاب الشيت فأصبر معى قليلا OK_Search - Copy.xlsm

نسخة من البرنامج من غير اسم البنك مع شرح ضبط الطباعة الملف بالمرفقات 2003 برنامج طباعة الشيكات نسخة الثانية - نسخة 2003.rar