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

وعليكم السلام تفضل وجدت لك وحدة نمطية تقوم بالمطلوب Public Function CreateLinks(strBEPath) As Boolean On Error GoTo Err_Handler Dim dbsFE As DAO.Database Dim dbsBE As DAO.Database Dim wksJET As DAO.Workspace Dim strTableName As String Dim strConnect As String Dim tdfBE As DAO.TableDef Dim tdfFE As DAO.TableDef Set wksJET = DBEngine.Workspaces(0) Set dbsBE = wksJET.OpenDatabase(txtPath) Set dbsFE = wksJET.OpenDatabase(txtPath1) For Each tdfBE In dbsBE.TableDefs If Left$(tdfBE.Name, 4) <> "MSys" And _ Len(tdfBE.Connect) = 0 Then strTableName = tdfBE.Name strConnect = ";DATABASE=" & strBEPath Set tdfFE = dbsFE.CreateTableDef(strTableName) tdfFE.Connect = strConnect tdfFE.SourceTableName = strTableName dbsFE.TableDefs.Append tdfFE Set tdfFE = Nothing End If Next tdfBE CreateLinks = True Exit_Handler: On Error Resume Next Set tdfFE = Nothing Set tdfBE = Nothing Set dbsFE = Nothing dbsBE.Close Set dbsBE = Nothing Set wksJET = Nothing Exit Function Err_Handler: MsgBox Err.Description, vbExclamation, "Error No: " & Err.Number Resume Exit_Handler End Function للذهاب إلى المصدر ‏‏kanory2.rar

جزاك الله خيرا أستاذى وأخى @jjafferr هذا الفارق دائما بين عطاء الأستاذ والتلميذ أحببت اضيف معلومة صغيرة طبعا حفظ الأرقام المقابلة للمفاتيح أمر بغاية الصعوبة وربما البحث عن هذه الأكواد عند الحاجة اليها ربما استقطع جزءا كبيرا من الوقت - لذا اتبع عادا استخدام هذا الكود لاظهار أرقام المفاتيح Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) MsgBox KeyCode End Sub وهكذا يخبرنا الأكسس بالأرقام من دون عناء

اليكم الملف تم تجربة بنجاح على اوفيس 2010 وعملت بها بعض اضافات و مسحت کود التأکید الانترنیت لأن ما اشتغل عندی حین عدم وجود الانترنیت وعگیت ھدول الرسائل و هذا هو الكود لنموذج التنزيل اوبديت للبرامج Option Compare Database Option Explicit Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef dwflags As Long, ByVal dwReserved As Long) As Long ' لتأکيد على اتصالك بالانترنيت Sub DownloadUpdate() Dim FileNum As Long Dim FileData() As Byte Dim MyFile As String Dim WHTTP As Object Dim str_folder As String Dim fShellRun As Object Set fShellRun = CreateObject("Wscript.Shell") On Error Resume Next Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5") If Err.Number <> 0 Then Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1") End If On Error GoTo 0 MyFile = "https://drive.google.com/drive/folders/0B9STtJY2DhAoQ1JET3F5N3NiMDQ" WHTTP.Open "GET", MyFile, False WHTTP.send FileData = WHTTP.ResponseBody Set WHTTP = Nothing If Dir("C:\MyDownloads", vbDirectory) = Empty Then MkDir "C:\MyDownloads" FileNum = FreeFile Open "C:\MyDownloads\Activation.mde" For Binary As #FileNum Put #FileNum, 1, FileData Close #FileNum DoCmd.OpenForm "frmrisale", acNormal Forms!FrmRisale.TimerInterval = 1000 Forms!FrmRisale!MyTxt.Caption = " [ C:\MyDownloads ]تم تنزيل ملف التفعيل في المسار التالي " Forms!FrmRisale!MyTxt.TopMargin = 100 str_folder = "C:\MyDownloads" ' folder to open Call Shell("explorer.exe " & str_folder, vbNormalFocus) 'DoCmd.Quit End Sub Private Sub Command0_Click() If GetIPAddress <> "127.0.0.1" Then Call DownloadUpdate Else DoCmd.OpenForm "frmrisale", acNormal Forms!FrmRisale.TimerInterval = 1000 Forms!FrmRisale!MyTxt.Caption = "انت غير متصل بالانترنيت .. تأكد من اتصالك بالانترنيت وحاول مجدداً " Forms!FrmRisale!MyTxt.TopMargin = 100 End If End Sub وهذا فانكشن للتأكيد على وجود الانترنيت Option Compare Database Option Explicit Public Const MIN_SOCKETS_REQD As Long = 1 Public Const WS_VERSION_REQD As Long = &H101 Public Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF& Public Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF& Public Const SOCKET_ERROR As Long = -1 Public Const WSADESCRIPTION_LEN = 257 Public Const WSASYS_STATUS_LEN = 129 Public Const MAX_WSADescription = 256 Public Const MAX_WSASYSStatus = 128 Public Type WSAData wVersion As Integer wHighVersion As Integer szDescription(0 To MAX_WSADescription) As Byte szSystemStatus(0 To MAX_WSASYSStatus) As Byte wMaxSockets As Integer wMaxUDPDG As Integer dwVendorInfo As Long End Type Type WSADataInfo wVersion As Integer wHighVersion As Integer szDescription As String * WSADESCRIPTION_LEN szSystemStatus As String * WSASYS_STATUS_LEN iMaxSockets As Integer iMaxUdpDg As Integer lpVendorInfo As String End Type Public Type HOSTENT hName As Long hAliases As Long hAddrType As Integer hLen As Integer hAddrList As Long End Type Declare Function WSAStartupInfo Lib "WSOCK32" Alias "WSAStartup" (ByVal wVersionRequested As Integer, lpWSADATA As WSADataInfo) As Long Declare Function WSACleanup Lib "WSOCK32" () As Long Declare Function WSAGetLastError Lib "WSOCK32" () As Long Declare Function WSAStartup Lib "WSOCK32" (ByVal wVersionRequired As Long, lpWSADATA As WSAData) As Long Declare Function gethostname Lib "WSOCK32" (ByVal szHost As String, ByVal dwHostLen As Long) As Long Declare Function gethostbyname Lib "WSOCK32" (ByVal szHost As String) As Long Declare Sub CopyMemoryIP Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long) Public Function GetIPAddress() As String Dim sHostName As String * 256 Dim lpHost As Long Dim HOST As HOSTENT Dim dwIPAddr As Long Dim tmpIPAddr() As Byte Dim i As Integer Dim sIPAddr As String If Not SocketsInitialize() Then GetIPAddress = "" Exit Function End If If gethostname(sHostName, 256) = SOCKET_ERROR Then GetIPAddress = "" MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name." SocketsCleanup Exit Function End If sHostName = Trim$(sHostName) lpHost = gethostbyname(sHostName) If lpHost = 0 Then GetIPAddress = "" MsgBox "Windows Sockets are not responding. " & "Unable to successfully get Host Name." SocketsCleanup Exit Function End If CopyMemoryIP HOST, lpHost, Len(HOST) CopyMemoryIP dwIPAddr, HOST.hAddrList, 4 ReDim tmpIPAddr(1 To HOST.hLen) CopyMemoryIP tmpIPAddr(1), dwIPAddr, HOST.hLen For i = 1 To HOST.hLen sIPAddr = sIPAddr & tmpIPAddr(i) & "." Next GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1) SocketsCleanup End Function Public Function GetIPHostName() As String Dim sHostName As String * 256 If Not SocketsInitialize() Then GetIPHostName = "" Exit Function End If If gethostname(sHostName, 256) = SOCKET_ERROR Then GetIPHostName = "" MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name." SocketsCleanup Exit Function End If GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1) SocketsCleanup End Function Public Function HiByte(ByVal wParam As Integer) HiByte = wParam \ &H100 And &HFF& End Function Public Function LoByte(ByVal wParam As Integer) LoByte = wParam And &HFF& End Function Public Sub SocketsCleanup() Dim ERROR_SUCCESS If WSACleanup() <> ERROR_SUCCESS Then MsgBox "Socket error occurred in Cleanup." End If End Sub Public Function SocketsInitialize() As Boolean Dim WSAD As WSAData Dim sLoByte As String Dim sHiByte As String Dim ERROR_SUCCESS If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then MsgBox "The 32-bit Windows Socket is not responding." SocketsInitialize = False Exit Function End If If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then MsgBox "This application requires a minimum of " & CStr(MIN_SOCKETS_REQD) & " supported sockets." SocketsInitialize = False Exit Function End If If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then sHiByte = CStr(HiByte(WSAD.wVersion)) sLoByte = CStr(LoByte(WSAD.wVersion)) MsgBox "Sockets version " & sLoByte & "." & sHiByte & " is not supported by 32-bit Windows Sockets." SocketsInitialize = False Exit Function End If SocketsInitialize = True End Function شکرا لك استاذ @sandanet على هذا الموضوع الرائع شكرا لك استاذنا @أبو عبدالله الحلوانى على المداخلة وشكرا لك استاذنا @jjafferr على مشاركتك .. لان مشاركتك يفرحنا ويعطينا الامل وهذا هو الملف بصيغة mdb تنزيل تحديث في رابط ثابت.rar

السلام عليكم وتكملة لإجابة أخي أبو عبدالله في صفحة كود الاكسس ، اعمل بحث لكلمة KeyCode ، وسترى اسماء حروف التي على الكيبورد ، مثل (وهذه نسخة من مساعد الاكسس) : vbKeyEscape vbKeySpace vbKeyPageUp vbKeyPageDown ... normal keys: vbKeyA vbKeyB vbKey8 vbKey9 ... numeric keypad: vbKeyDecimal vbKeyDivide ... function keys: vbKeyF10 vbKeyF11 . والرابط التالي يعطيك اسم الزر ورقمه: https://msdn.microsoft.com/en-us/library/0z084th3(v=vs.90).aspx والآن ، وفي الاكسس ابحث عن Form_KeyDown ، وسترى كود مشابه وعليه ، لتعطيل اي زر ، نستعمل رقمه ، كما ذكره اخي ابو عبدالله ، او كما هو في الاكسس ، هكذا Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) Select Case KeyCode Case vbKeyF11 KeyCode = 0 Case 16 'vbKeyShify KeyCode = 0 End Select End Sub . والآن الى الشيء الاهم: لما نكون في النموذج ، ونكون نكتب معلومة في حقل نص/مذكرة ، ولا نريد من المستخدم كتابة اشارة التقسيم "/" مثلا ، لذا يجب ان يصطاد النموذج هذا الزر قبل ان يدخل في النص ، لذا يجب عليك ان تعدل في اعدادت النموذج وتجعل اعداد KeyPreview=Yes . او تستعمل حدث تحميل النموذج ، وتضع عليه كود التفعيل اعلاه: Private Sub Form_Load() Me.KeyPreview = True End Sub جعفر

استاذ @sandanet عند تنفيذ الكود ظهر هذا الخطأ وقد تم اضافة هاتين الجملتين الى الكود وعمل بنجاح والحمد لله Dim fShellRun As Object Set fShellRun = CreateObject("Wscript.Shell") strPing = fShellRun.Run(strCommand) الا انه عند عدم وجود اتصال بالانتر نت لا يوجد اعتراض من قبل الكود وتم اهمال ارسال الرسالة التنبيهية بعدم وجود اتصال

السلام عليكم بما ان أخي شفان جاء بكود اخونا أبو ابراهيم الغامدي ، فاليك التغيير المطلوب لحل مشكلتك: Function GetNumbersOnly(SText) Dim Numbers if len(SText & "")=0 then GetNumbersOnly="" exit function end if For i = 1 To Len(SText) If IsNumeric(Mid(SText, i, 1)) Then Numbers = Numbers & Mid(SText, i, 1) End If Next GetNumbersOnly = Trim(Numbers) End Function جعفر

السلام عليكم ورحمة الله وبركاته اخوتي الاكارم تحية طيبة وبعد المثال المرفق يبين كيف نتمكن من جلب اكثر من صورة دفعة واحدة تأخذ كل صورة منها رقما متسلسلا في الجدول الفرعي ضمن رقم المعرف الرئيسي . يوجد في المثال : جدول tbl1 باعتباره جدولا فرعيا منبثقا من الجدول الرئيسي نموذج photo يمكن جعله نموذجا فرعيا لمن يجيد تحوير الكود المصاحب علما ان الافضل استخدامه كما هو ويتم جلب المعرف الرئيسي اليه في حقل خاص غير منضم مع الاخذ بالاعتبار فيما لو وجد صور سابقة بمعنى ان المثال يضيف صورا جديدة الى الصور القديمة ان وجدت وفي المثال تطبيق للمقال اكثر من صورة.rar

هذه الحلقة فيها شرح كافي ووافي إن شاء الله لموضوع الفرز

شكر لك اخي علي النصحيه شاكر لك من كل قلبي وهذا يدل على حسن اخلاقك نبهتني كنت دوما ادعي فيها (الدين النصيحه ) تحياتي لك

السلام عليكم شباب انا ساكت واستمتع بالتطورات ، لكن مخي يمخخ وراح بعيد لكيفية الاستفادة من هذه الخطوة مادمتم قد قطعتوا المشوار في هذا الطريق البديع (شكرا أخي أوس على الفكرة والكود ، ابو عبدالله وشفان على تعديل الكود) ، فبدل ان ابدأ من البداية ، سوف اضع امامكم الفكرة اللي على بالي ، راجيا منكم بلورتها برمجيا خلينا نتوسع في الفكرة شوي ، لتشمل احتياجات المبرمج ، فاللي على بالي هو: 1. البرنامج يدخل على مجلد معين في الموقع (وحاليا كلامنا عن Google Drive) (كما هو الحال الآن) ، ويكون فيه ملف نص txt او xml ، ويُنزل هذا الملف ، 2. هذا الملف يكون فيه اسماء برامجي ، ورقم النسخة الموجودة ، واسم مجلد الموقع الذي فيه هذه البرامج (مجلد آخر في Google Drive ، يعني اعمل مجلد لكل برنامج من برامجي) ، (طبعا نستطيع ان نضيف تاريخ من ، تاريخ الى ، نوع البرنامج: Full او Demo او Activation ، و....) ، والنص يكون هكذا مثلا : Enquiry_Book,2.0,0B9STtJY2DhAoQ1JET3F5N3NiMDQ myAccounting,1.5,0B9STtJY2DhAoQ1JET3F5N3Nuwiu Archiving_Goods,5.23,0B9STtJY2DhAoQ1JET3F5Nlujhft 3. البرنامج يُنزل هذا الملف ويقرأه ، ويقارن نسخة البرنامج (سيكون هناك جدول خاص في البرنامج ، وبه رقم نسخة البرنامج) ، 4. البرنامج سيقارن رقم النسخة من الجدول ، مع رقم نسخة البرنامج الموجودة في ملف النص ، 5. اذا كان رقم النسخة الموجودة في الملف/الموقع اكبر من النسخة الموجودة في البرنامج ، فيعطي رسالة للمستخدم بأنه هناك نسخة احدث للبرنامج ، وسيقوم بإنزالها وتنصيبها ، 6. البرنامج سيقوم بإستخدام نفس الكود اعلاه (طبعا مع تغييرات بسيطة اذا دعى الامر ، او نجعل الكود كوحدة نمطية نستطيع استعمالها لإنزال مختلف الملفات من الموقع) ، ويُنزل البرنامج. بهذه الطريقة المبرمج يستطيع ان يُحدث برامجه عالميا ، وبدون الذهاب الى مكتب المستخدم مجرد فكرة جعفر

اشكرك جزيل الشكر استاذي الكبير @Shivan Rekany جاري تجربة ماتفضلت به .. في الحقيقة ان مشاركتك في الموضوع في بدايته كانت ذو فائدة عظيمة أدت الى تلك النتائج .. كما ان مشاركة اساتذتي الكرام الآخرين وعلى رأسهم الاستاذ جعفر كانت هي الحافز الكبير لدي للبحث المستمر حتى النهاية الموضوع من وجهة نظري مهم جداً وسوف يحتاجه الاخوة الافاضل لعمل تحديث لبرامجهم عن طريق الانترنت .. الموضوع قد طرحته قبل فترة لكن لم يتم التعقيب عليه وكنت شخصياً قد نسيته الى ان قام الاخ ebnjabalapp بالرد عليه مشكوراً ..فتحياتي لكم جميعاً

اتفضل اليك هذا الكود Private Sub NO_2_BeforeUpdate(Cancel As Integer) Dim MyDcount As Integer Dim MyId As Integer MyId = DLookup("[ID]", "التحويلة", "[رقم التحويلة]=" & Me.NO_2) MyDcount = DCount("*", "التحويلة", "[رقم التحويلة]=" & Me.NO_2) If MyDcount > 0 Then MsgBox "ھذا الرقم محجوزة .. سيتم نقلك اليه" Me.Undo Me.RecordsetClone.FindFirst "[id] = " & MyId Me.Bookmark = Me.RecordsetClone.Bookmark End If End Sub انا عم استخدم اوفيس 2010 وما فيها مشكلة لا تتعصب .. اهتم بصحتك اليك المرفق بعد تعديل --دليل ارقام التحويلات2.rar

وعليكم السلام أخي الكريم محمد السؤال عام والإجابة ستكون عامة بالفعل يمكن عمل كل ما ذكرته ، ويمكن الاستعانة بمسجل الماكرو لتتعلم من خلاله أوتطرح موضوع لكل نقطة تريدها مع إرفاق ملف مرفق مع وضع بعض النتائج المتوقعة وكل ما ذكرته متاح ويسير إن شاء الله وستجد استجابة من الجميع تقبل تحياتي

وعليكم السلام تفضل الاشارة " يمكن الاشارة اليها برقمها ، والذي هو (chr(34 وهذا لباقي ارقام وحروف الكمبيوتر: http://www.asciitable.com/ فعليه ، نستخدم الامر Replace لإزالة هذه الاشارات ، هكذا: Field1: Replace([Field_xyz],chr(34),"") والنتيجة جعفر 687.tarek.accdb.zip

وعليكم السلام 1. اعمل ضغط واصلاح لبرنامج البيانات BE ، وكذلك لبرنامج الواجهة FE ، 2. واذا حبيت ، خلينا نشوف الكود ، واللي ممكن نتوصل الى شيء يفيدك. جعفر

يمكنك ذلك عن طريق استخدام التنسيق الشرطى Conditional Formatting وممكن ترفع الملف ونطبق عليه المطلوب

جرب هذا الملف في النطاق A1:C8 talween.rar

وعليكم السلام جرب المرفق اعتقد أنه يعمل على نطاع الفورم لا على نطاق الأبلكيشن StopF4.rar

استاذي @أبو عبدالله الحلوانى اعتذر عن هذا الخطأ الغير مقصود فنسيت ان اضيف التالي Option Explicit Option Compare Database Dim strPing As String Dim strCommand As String Dim myIp والكود يعمل لدي بنجاح على اكسس 2007 وسأقوم بتجربته لاحقاً على اكسس 2003 ايضاً ان شاء الله

اكنب هذه المعادلة و اسحبها يساراً 4 اعمدة =INDEX($A$4:$D$6,MATCH($H$4,$B$4:$B$6,0),COLUMNS($A$1:A1))

بفضل الله أولاً ومن ثم بفضل فكرة استاذي الكبير @Shivan Rekany تمكنت من ايجاد الكود التالي مع بعض التعديلات عليه ليقوم بالمهمة المطلوبة Sub DownloadUpdate() Dim FileNum As Long Dim FileData() As Byte Dim MyFile As String Dim WHTTP As Object Dim str_folder As String On Error Resume Next myIp = "www.google.com" strCommand = "%ComSpec% /C %SystemRoot%\system32\ping.exe -n 1 -w 500 " & myIp & " | " & "%SystemRoot%\system32\find.exe /i " & Chr(34) & "TTL=" & Chr(34) strPing = fShellRun(strCommand) If strPing = "" Then MsgBox "تحقق من اتصالك بالانترنت لكي يتم تنزيل الملف", vbCritical, "فشل التحديث" Else Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5") If Err.Number <> 0 Then Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1") End If On Error GoTo 0 MyFile = "https://drive.google.com/drive/folders/0B9STtJY2DhAoQ1JET3F5N3NiMDQ" WHTTP.Open "GET", MyFile, False WHTTP.send FileData = WHTTP.ResponseBody Set WHTTP = Nothing If Dir("C:\MyDownloads", vbDirectory) = Empty Then MkDir "C:\MyDownloads" FileNum = FreeFile Open "C:\MyDownloads\Activation.mde" For Binary As #FileNum Put #FileNum, 1, FileData Close #FileNum MsgBox " [ C:\MyDownloads ]تم تنزيل ملف التفعيل في المسار التالي", vbInformation + vbMsgBoxRight, "تنبيه" str_folder = "C:\MyDownloads" ' folder to open Call Shell("explorer.exe " & str_folder, vbNormalFocus) DoCmd.Quit End If

السلام عليكم ورحمة الله الكود يصلح للعديد من الشيتات المهم ان تكون اسماؤها متطابقة

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

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

استاذي الفاضل @أ / محمد صالح المشكلة في الاستضافة المجانية انها لن تبقى مجانية لفترة طويلة لذلك يلزمني عمل استضافة مدفوعة وهنا يتطلب الامر الى الدفع بالفيزا كارد وانا لا املك واحدة .. استاذي القدير @Shivan Rekany الغرض من الفكرة هو جعل البرنامج المعمول على الاكسس يقوم بتنزل الملف التنفيذي بدون تدخل .. لكن فكرتك اقرب الى ان تكون هي الحل المناسب لي وذلك عن طريق عمل مجلد واخذ رابطه ووضعه في البرنامج حيث يمكني لاحقاً تغيير مابداخل المجلد فقط .. جاري التجربة تحياتي لكم

ھذا فقط تفكير اعمل فولدر وقم بعمل رابط للفولدر وبعدين احتمال ان تقدر تتغير مافي داخلة بنفس الرابط للتجربة : اليك هذا الرابط به صورة فقط https://drive.google.com/drive/folders/0Bw7lKz1UIsW1MEdadDh0OVBWVmM اعمل تنزيل له وبعدين اي بعد تعمل التنزيل راح اعطيك نفس الرابط وبه صور اخر غير هذا

في هذه الحالة يلزمك حساب على موقع استضافة مجانية أو مدفوعة http://www.hostingadvice.com/how-to/free-web-hosting/

أ / هشام ربنا يكرمك ويحفظك أنا بصراحة مش فاهم قصد حضرتك بالضبط بس حضرتك ممكن تعمل Data Validation وتختار منها الأسماء بدل كتابة الأسماء فى كل مرة وممكن أحد الأساتذة الأفاضل يفيدك فى حل أفضل حصور وإنصراف.rar

اتفضل =IIf([نص582]>[نص580];"+" & ([نص580]/[نص582]);IIf([نص582]<[نص580];"-" & ([نص580]/[نص582]);([نص580]/[نص582]))) لكن هناك اريد اسألك هل تريد ان تعرف نسبة الفرق بين الرقمين بالنسبة المؤية او نسبة المؤوية بين الرقمين ؟ لان الجوابي هو لنسبة المؤيو بين الرقمين وليس نسبة الفرق بين الرقمين بالنسبة المؤوية نسبة الفرق بين رقمين متغيرين.rar

يمكن ذالك عن طريق اتباع الشرح الخاص باستاذنا الجليل ياسر خليل بالاعلى او كما يمكن ذالك عن طريق وضع الكود الحالى بثلاث صيغ والدلاله واحده بالنهاية Private Sub UserForm_Initialize() 'الطريقة الاولى If Label1.Caption <> "" Then Label1.Caption = Sheets(1).Range("a1").Value End If 'الطريقة الثانية Label2.Caption = Range("b1") 'الطريقة الثالثة Label3.Caption = Range("c1").Value 'CommandButton 'الطريقة الاولى If Label1.Caption <> "" Then CommandButton1.Caption = Sheets(1).Range("a2").Value End If 'الطريقة الثانية CommandButton2.Caption = Range("b2") 'الطريقة الثالثة CommandButton3.Caption = Range("c2").Value End Sub ومرفق ملف لتوضيح الامر 1010.rar كما بالامكان البحث بالموضوعات القديمة وستجد كل ما ترغب به ان شاء الله ومثال على ذالك الرابط التالى

اخوتي الكرام السلام عليكم ورحمة الله وبركاته العنوان ينطق بالمعنى كيف يعمل مستخدمون كثيرون ضمن نموذج واحد ولكن كل حسب صلاحيته وتطبيقه على ارض الواقع في البرنامج المدرسي حيث يتسنى لكل معلم ادخال درجات طلابه لا يشاركه في ذلك احد الا المسؤول عن البرنامج وهو جزء من درس احببت افراده ارفقت مثال بسيط عبارة عن جدولين ونموذجين يشتمل على 13 معلما ومسؤول واحد كلمات المرور للمعلمين تبدأ من 101 وحتى 113 وكلمة مرور المسؤول = 222 بيت القصيد والذي تدور عليه العمليه هو حقل رقم المعلم ويوجد مخفيا في حقل داخل النموذج لللاستزادة ورؤية التطبيق من هنا http://www.officena.net/ib/index.php?showtopic=55142&page=4#entry350160 آمل ان تجدوا الفائدة myUser.rar

الحلقة الثالثة عشر ******************* السلام عليكم ورحمة الله وبركاته إخواني الأحباب في المنتدى الأغر ..نأسف على عدم فتح الباب الفترة اللي فاتت بسبب البرد الشديد ، وبعد ما الجو اتظبط شوية نقدر نفتح الباب عشان الشمس تدخل وتدفنيا.. من أول الحلقة دي إن شاء الله هنبدأ نتعامل مع مهارات التعامل مع محرر الأكواد ، عايزين نوصل للأحتراف .. هنتكلم عن مهارة كتير بنحتاج نتعلمها ، ألا وهي الفرز أو الترتيب أو ما يطلق عليها باللغة اللي مش عربية Sort هنشتغل عملي علطول (أو على عرض ..مش هتفرق كتير) ..نفتح مع بعض ورقة عمل ، ومحدش يستنى مني إني أرفق ملف ، لأنك عشان تتعلم يبقا لازم تشتغل بايدك سيبك بقا من شغل النظري اللي مبيوكلش عيش ده ! افتح يا محسن ، شعارنا في الحلقات افتح (مرة افتح الباب ..افتح مصنف جديد ..افتح الخيارات في البرنامج ..افتح محرر الأكواد .. وشوية واحد هيقولي لو مبطلتش رغي هآجي أفتح دماغك وأريح الناس من رغيك) نفتح ورقة العمل ونكتب شوية بيانات عشان هنشتغل عليها ...وعشان أريحكو أدي شوية بيانات بدل ما تتعبوا ايديكم يا أحباب ، أنا بردو يهمني راحتكم م الاسم النوع 1 ياسر ذكر 2 احمد ذكر 3 ابراهيم ذكر 4 حسام ذكر 5 سليم ذكر 6 ماجدة أنثى 7 هدى أنثى 8 محمد ذكر 9 دينا أنثى 10 نور ذكر 11 رضا ذكر 12 سلمى أنثى 13 فاروق ذكر 14 شهد أنثى 15 كمال ذكر 16 طارق ذكر 17 هدير أنثى 18 سارة أنثى 19 أميرة أنثى حدد البيانات وتعالى لورقة العمل في الخلية A1 ، واعمل كليك يمين ، ثم اختر Paste Special (لصق خاص) ثم اختر من النافذة اللي هتطلع لك Text ، بكدا هتلاقي عندك 3 أعمدة (عمود للمسلسل ودا عشان مسلسل افتح الباب ، وعمود الأسماء ، وعمود النوع.. ) ويا ريت ننسخ البيانات في نطاق تاني مرة تانية لأننا هنجرب عليها أكتر من تجربة (ضعها مرة أخرى في النطاق K1:M20 مثلاً )!! المطلوب : ترتيب البيانات حسب الاسم ، ودا أمر بسيط جدا ومش معقد أبداً .. طريقة الحل : نروح للتبويب Developer ثم نختار Record Macro ثم نقف في الخلية A1 في بداية البيانات ، ونروح للتبويب Data ثم الأمر Sort ونختار من الحقل اللي اسمه Sort By نختار الاسم (لأن هو دا الحقل المطلوب الترتيب على أساسه) ، وفي الحقل الثالث المسمى Order (ودا شكل الترتيب ونختار يا أستاذ مختار A to Z (هتلاقي هو دا الخص الافتراضي أقصد الخيار الافتراضي ) يعني الترتيب أو الفرز حاجة من اتنين يا إما تصاعدي A to Z (من تحت لفوق) ودا بيسموه الجماعة اللي ما يتسموا (Ascending) أو تنازلي Z to A (من فوق لتحت) ودا اللي بيسموه في اللغة الأجنبية Descending ، وعشان ميحصلش عندك لخبطة الكلمة Ascending بتبدأ بحرف الـ A تبقا دي A to Z (الترتيب التصاعدي) !! كل دا إحنا بنسجل يا حسين (اعدل الكرافتة عشان صورتك تطلع حلوة) ..Stop أنا المخرج وبقول Stop يعني وقف التسجيل .. ياااااااه كانت حلقة صعبة أوي الحلقة دي ، التسجيل بيحتاج مجهود جبار عشان تطلع الحلقة حلوة ولذيذة !!! دلوقتي جه وقت الجد ، اللي إحنا منعرفوش ، ندخل المغارة (على رأي الكبير حسام عيسى ..صقر المنتدى) ، هندخل المغارة عن طريق Alt + F11 معلومة قديمة ، طيب هندخل نعمل ايه ؟ أكيد هندخل عشان ندور على الكنز ..مش دي بردو مغارة ياسر بابا !! هنلاقي الكنز بس مدفوووووووون تحت الأنقاض Sub Macro1() ' ' Macro1 Macro ' ' Range("A1:C20").Select ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B2:B20") _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Sheet1").Sort .SetRange Range("A1:C20") .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Sub دا اللي إحنا سجلناه ..إحنا طلعنا شطار وبنعرف نسجل كويس جداً ..الكنز فين يا نور العين؟ الكنز مدفون ما بين الأسطر ..إزاي نقدر نخرجه.. أقولكم دا كله هتش !! اللي عمله محرر الأكواد في سنين هنختصره إحنا في ثانية واحدة وبسطر واحد (وهي دي الشطارة !!) Range("A1:C20").Sort Key1:=Range("B1:B20"), Order1:=xlAscending, Header:=xlYes ضع هذا السطر اللذيذ في إجراء فرعي وجربه ، هنلاقي إنه يبنفذ نفس الكود الطويل اللي سعادة محرر الأكواد سجله . طيب نهضم السطر اللي اتكتب : أول شيء عشان تقدر تتعامل في أي كود إنك تحدد الخلية أو النطاق اللي هتتشغل عليه ، وأظن دي واضحة جدا ، فالنطاق اللي هنشتغل عليه واللي فيه البيانات هو A1:C20 ، وممكن في الكود نحدد أول خلية في النطاق بس يعني ممكن يكون شكله كدا : Range("A1") بس أنا أفضل إننا نكتب النطاق بالكامل ، وبعد ما حددنا النطاق ، نطلق الحدث أي الفعل ، يعني السؤال المتوقع ايه المطلوب نعمله في النطاق : الإجابة نطبطب عليه وندلعه ، إجاية غير صحيحة ، الإجابة إننا نفرسه (هذه هي الإجابة الصحيحة ..نعم نفرزه ونرتبه زي ما إحنا عايزين) والفرز بيكون بكلمة Sort ونترك مسافة واحدة بالمسطرة بعد الفرز .. ونبدأ نشوف حاجة اسمها بارامترات الحدث Method ، ودي ممكن نشوفها في تسجيل الماكرو اللي قام بيه محرر الأكواد .. إحنا هناخد المهم وبس ، ميهمناش الدش الكتير !! أول بارامتر هو مفتاح الفرز أو الترتيب Key، بمعنى آخر المقصود بيه العمود اللي هيتم على أساسه الفرز ، والعمود هنا هو عمود الأسماء B1:B20 ، ونفس الكلام ممكن نستغنى عن النطاق بالكامل ونذكر فقط أول خلية في العمود B1 بالشكل ده Key1:=Range("B1") طيب محدش سأل ايه الواحد اللي جنب المفتاح (دا الحارس الشخصي للمفتاح عشان محدش يسرقه) ..الواحد ده يا أساتذة هو المفتاح الأول لعملية الفرز ، وهنفهم الحتة دي لما ناخد مثال تاني ... بعد كلمة Key1 نقطتين فوق بعض (Shift + حرف الكاف : ) وسواء وإنت بتكتب عربي أو إنجليزي (الاتنين سواسية).. يليها علامة يساوي .. ومعروف إن علامة يساوي ييجي بعدها قيمة ، ونترجم الكلام ده إن قيمة المفتاح الأول هو النطاق B1:B20 (أفضل إنه يتكتب نطاق العمود بالكامل) ناخد فاصل ، لا مش هنريح يا عبد الله ، أقصد فاصلة مش فاصل ، الفاصلة دي هي اللي بتفصل بين البارامترات يا أحباب .. ننتقل للبارامتر الثاني والمسمى Order ودا ترجمته يا أخ ابو سليمان (الترتيب ..) دلوقتي هتدعي عليه ، وتقولي يا عم إنت مش قلت كلمة Sort دي معناها ترتيب ..أيوا مش هنكر ..بس عشان تتضح الصورة كلمة Sort هنا فعل أو حدث Method ، أما كلمة Order تعتبر زي الاسم وممكن نقول إن البارامترات دي وصف لكيفية حدوث الحدث ، أي الطرق المؤدية لحدوث الحدث !! أنا تهت زيكم بالظبط المهم المقصود منها نوعية الترتيب هنا (هل الترتيب تصاعدي أم تنازلي) ، وبردو كلمة Order جنبها رقم واحد (الحارس الشخصي) ..يليها نقطتين وعلامة يساوي ، وقيمتها إما xlAscending أو xlDescending (أظن مفهومة يا أبو سليمان) ناخد فاصلة تانية وأوعدك دي تكون آخر فاصلة في السطر ده ..البارامتر الثالث هو المسمى Header ودي ترجمتها حقول البيانات أو عناوينها .. نسأل هل للبيانات اللي موجودة عناوين ولا لا ؟؟ م ، والاسم ، والنوع (دي عناوين أو حقول للبيانات) .. الإجابة نعم xlYes معلومة جديدة نستفيد منها إن الحدث Mehod قد يتبعه بارامترات ، وتأتي هذه البارامترات بعد الحدث Method بمسافة بينهما ، يعني اللي بيفصل بين الحدث والبارامترات هي المسافة (دي المحرم..) ..أما البارامترات فبيتم الفصل بين كل واحد وأخوه بفاصلة , .. حاجة تانية لما تلاقي النقطتين فوق بعض وبعدين علامة يساوي تعرف إن دا بارامتر .. يا رب تكون المعلومة مفيدة. طيب سؤال من الأستاذ طارق : هل البيانات لازم يكون فيها عنوان عشان نعمل فرز ؟؟ جاوب إنت يا عبد الكريم ، عبد الكريم : يا أستاذ طارق طالما فيه بارامتر بيسأل هل فيه عنوان أو مفيش ، يبقا أكيد ممكن إننا نفرز من غير عناوين البيانات .. الله ينور عليك يا أستاذ عبد الكريم ، وميحرمناش منك ، فعلا الكلام دا صحيح .. نشوف السطر ده بيأدي نفس الغرض ، استغنينا عن صف العناوين : Range("A2:C20").Sort Key1:=Range("B2:B20"), Order1:=xlAscending, Header:=xlNo النطاق بدأ من A2 بعيداً عن عناوين البيانات ، والمفتاح كمان بدأ من B2 ، ونخلي بالنا من قيمة البارامتر Header هنلاقيه xlNo (يعني مفيش عناوين). ********************************* ننتقل لجزئية تانية .. الجزئية اللي فاتت أخدت حقها وزيادة ، دلوقتي واحد بيبص لي وبيقولي ايه شكل البيانات الملخبطة دي ..حد يفرز الأسماء ويخلي كله مع بعضه (ذكور مع إناث) دا إنت راجل محترم حتى عيب عليك !! ..ردي : أنا آسف والله يا حاج محمد مكانش قصدي ، دا كان مجرد مثال عموما عنيا ليك هنعيد ترتيبهم زي ما إنت عايز (حضرتك أكيد عايز الذكور أولا وبعدين الإناث ) ..رد وقال : كدا عين العقل .. بسيطة يا حاج محمد : السطر الخاص بالفرز هنزود عليه مفتاح كمان ، وشكل لترتيب المفتاح الجديد ... قبل ما أضع السطر ..عايزين نعود نفسنا إننا ندي نفسنا مساحة من التفكير قبل التنفيذ .. الفرز المرة دي هيكون على عمودين (مين قبل مين .. يعني عمود الاسم الأول ولا عمود النوع ؟؟ الإجابة بسيطة عمود النوع عشان نفصل بين الذكور والإناث : أي خدمة يا حاج محمد) إذاً الفرز هكيون لعمود النوع (ذكر ، أثنى ) ، نبص في أول حرف في ذكر وأول حرف في أنثى (محدش يبص على كل الحروف عيب) أول حرف هو حرف الذال في كلمة ذكر ، وألف في كلمة أنثى : طيب الكلمتين دول الألف الأول ، بمعنى تاني لو تركنا الخيار xlAscending اللي هو الترتيب التصاعدي بكدا هيكون الإناث الأول وبعدين الذكور حسب الترتيب الأبجدي ، إذاً في الحالة دي هنكتب xlDescending (عشان تتم عملية الفرز ذكر ثم أنثى) نأتي للتطبيق العملي : ها هو السطر ... Range("A1:C20").Sort Key1:=Range("C1:C20"), Order1:=xlDescending, Key2:=Range("B1:B20"), Order2:=xlAscending, Header:=xlYes هنشبه السطر دا بشقة ليها بابين : أقصد بالبابين عمودين الترتيب (عمود النوع ثم عمود الأسماء) ، كل باب له مفتاح عشان يفتح بيه .. الباب الأول عمود النوع ومفتاحه رقم 1 ، وشكل ترتيبه أو نوع ترتيبه تنازلي (عمود النوع) Key1:=Range("C1:C20"), Order1:=xlDescending والباب التاني ومفتاحه رقم 2 ، وشكل أو نوع ترتيبه تصاعدي (عمود الأسماء) Key2:=Range("B1:B20"), Order2:=xlAscending طبعا المفتاح ده ميشتغلش على ده ، ولا ده يشتغل على ده ، إنما ده لده وده لده (معلش هيست شوية) مفتاح النوع هيعتمد على النطاق C1:C20 ، ومفتاح الأسماء هيعتمد على النطاق B1:B20 ، كل مفتاح يلعب في ملعبه أقصد في بابه ، أقصد في العمود الخاص بيه. وبكدا لما ننفذ السطر اللي فات ، نقدر نحصل على النتيجة التي ينتظرها الحاج محمد.. الحاجة أم محمد شكلها مكشر وزعلت وبتقول بالإنجليزي : Ladies First يا مان (معلش أصلها مثقفة حبتين) أوك يا حاجة ولا تزعلي نفسك .. الفكرة بأبسط مما تتخيلي غيري كلمة واحدة ، وألا أقولك متتعبيش نفسك شيلي حرفين وحطي حرف واحد بس شيلي حرفي De في كلمة Descending وحطي حرف الـ A (شفتي بقا إنها بسيطة .. متنسيش الفطير عشان مستر حسام) يا للروعة !! الحاجة أم محمد مش مصدقة نفسها .عموما جربوا (مش تجربوا الكود .. جربوا فطير أم محمد هيعجبكم جداً ، وبعد ما تاكلوا وتتمتعوا بالفطير جربوا الكود بعد التعديل ..) ********************************* ننتقل لجزئية أخيرة تهم نفس الموضوع ...ألا وهي ألا وهي (تصدقوا نسيت) افتكرت .. إزاي أخلي النطاق غير محدد أو ديناميكي .. إحنا لما اتعاملنا مع النطاق حددنا النطاق لحد الصف رقم 20 في المثالين اللي فاتوا .... عايزين يكون الكود مرن ، يعني يمشي مع أي عدد من الصفوف ، لأن قواعد البيانات معروف إنها مش ثابتة .. يبقا المطلوب الجديد إننا نخلي آخر صف مفتوح ، أو من خلال الكود نخلي محرر الأكواد هو اللي يحدد آخر صف مش إحنا .. مستر حسام عيسى تناول (الفطيرة بتاعت أم محمد) وأيضاً تناول هذه النقطة في شرح رائع له .. نشرحها تاني ..ونخلي بالنا ، وخلينا جد بقا شوية ومركزين أوي لأن الحتة دي تقريبا مفيش مبرمج بيستغنى عنها (آه والله زي ما بقولكم كدا) نفرض دلوقتي إننا مش عارفين آخر صف ..نجيبه إزاي .. الإجاية نسجل ماكرو (واحد مبرق ومش فاهم أيوا هنسجل ماكرو ..بردو مبرق ) بص يا مبرق : ابدأ تسجيل و تعالى في العمود الأول A واقف بعيد تحت بعد البيانات بمسافة كبيرة وليكن مثلا A100 ، وبعدين اضغط Ctrl + سهم لفوق من لوحة الأسهم .بس خلااااص انتهى التسجيل ، نروح لمحرر الأكواد هنلاقي الشكل ده Range("A100").Select Selection.End(xlUp).Select وممكن نختصره في سطر واحد بس إننا نشيل كلمة Selection ونحط مكانها النطاق Range("A100").End(xlUp).Select عايز تطبق الكود ده ، روح لأي خلية بعيدة في أي عمود واضغط Alt+F8 وشوف الماكرو اللي فيه السطر اللي فات اسمه ايه واضغط Run.. نفهم إزاي هنستغل الحتة دي في إننا نعرف آخر سطر به بيانات في العمود A .. نقطة البداية هي A100 ، والكلمة End(xlUp) دي لما ضغطنا Ctrl وسهم لفوق المحرر ترجمها كدا ، يعني اطلع لفوق Up يا سفن أب يا لذيذ يا رايق (ما هو لازم نهضم الفطير اللي أكلناه) طيب واحد بيقولي بس دا مش حل لأني أساسا معرفش البيانات دي آخرها فين ، بلاش استعباط .هرد عليه وأقوله : الله يسامحك ، ما هو لو صبر القاتل ع المقتول كان مات لوحده ... إحنا هنخلي رقم الصف 100 هو آخر صف في ورقة العمل ، بالنسبة لـ 2003 آخر صف 65536 ، أما في 2007 فما فوق فعدد الصفوف 1048576 (يا دي الحيرة ..يعني نغير رقم 100 لأي رقم فيهم) ..اللي يحيرك طيره ، يعني لا هنستخدم الرقم ده ولا ده إحنا هنخلي المحرر هو اللي يعد الصفوف كلها بالسطر ده ، سبق وشرحناه في النافذة الفورية MsgBox Rows.Count بس إحنا مش عايزينها في رسالة ..دا بس عشان تتضح الصورة ، كلمة Rows تعني صفوف يا أبو سليمان ، وكلمة Count يعني يا محرر اتفضل عد. هكيون الناتج لتنفيذ السطر اللي فات مختلف حسب إصدار الأوفيس اللي عندك ، لو 2003 هيطلع الناتج 65536 ، ولو الأوفيس 2007 فما فوق هيطلع الناتج 1048576 (أكيد فيه ناس تاااهت مني .. الفطير عمل عمايله معاكم) يرجع مرجوعنا لموضوعنا الأصلي عرفنا عدد الصفوف من خلال محرر الاكواد ، يبقا هنشيل رقم 100 ونحط Rows.Count وبس Range("A" & Rows.Count).End(xlUp).Select نخلي بالنا الرقم 100 كان داخل أقواس التنصيص ، لكن لما استخدمنا الجملة Rows.Count الأقواس طردتها براها ، لأنها الأقواس مش بتقبل المتغير ، وعدد الصفوف هنا يا أحباب وركزوا متغير حسب الإصدار ، لكنها بردو حنينه مهانش عليها تطرده قامت حضنته بعلامة & عشان يكون جنبها طيب نرجع تاني للهدف من دا كله إننا نعرف رقم آخر صف فيه بيانات ، إحنا بالسطر الأخير عرفنا نحدده لكن إزاي نعرف رقم صفه .. هنشيل Select ونحط Row وبس .. لا محدش يقولي بس !! كدا السطر دا بالشكل ده Range("A" & Rows.Count).End(xlUp).Row لو نفذت السطر ده هيقولك محرر الأكواد يا أهبل ايه ده ويطلع لك رسالة خطأ Invalid Use استخدام خاطيء.. السطر صحيح ، بس السطر عبارة عن رقم (اللي هو رقم الصف الأخير اللي فيه بيانات) بس الرقم دا مينفعش يقف لوحده يخاف ياخد برد .. لازم نحط الرقم ده في متغير .. Dim LR As Long LR = Range("A" & Rows.Count).End(xlUp).Row MsgBox LR عملنا متغير باسم LR ودي اختصار Last Row أو الصف الأخير (بس التسمية اختياري يا شباب) ووضعنا قيمة للمتغير اللي سميناه LR في السطر الثاني ، فأصبح المتغير LR يحمل الآن رقم الصف الأخير وفي السطر الثالث عشان نختبر مدى صحة الكود ونشوف النتيجة عملنا رسالة يظهر فيها قيمة المتغير .. ** ملحوظة هامة : ممكن السطر الثاني نستخدم كلمة Cells بدلاً من كلمة Range بس هيكون التركيب مختلفة شوية ، لأن مع كلمة Cells بيكون فيه جزئين : الجزء الأول رقم الصف والجزء الثاني رقم العمود ، معنى الكلام ده إن Cells بتتعامل مع أرقام ، فيكون شكل الكود اللي فات لو استخدمنا Cells بهذا الشكل : Dim LR As Long LR = Cells(Rows.Count, 1).End(xlUp).Row MsgBox LR طبعاً Rows.Count تمثل رقم آخر صف به بيانات ، ورقم واحد بيمثل رقم العمود الأول A >>>>> نفذ الكود سواء اللي فات أو اللي قبله !! هنلاقي رقم الصف الأخير طلع في رسالة (أنا طلعت عيني وأكيد إنتو كمان .. يعني اللفة الطويلة دي عشان نعرف رقم آخر صف به بيانات.) دلوقتي جه الوقت إني أودعكم .. نشوف شكل الكود في النهاية هيكون عامل إزاي Sub SortData() Dim LR As Long LR = Range("A" & Rows.Count).End(xlUp).Row Range("A1:C" & LR).Sort Key1:=Range("C1:C" & LR), Order1:=xlDescending, Key2:=Range("B1:B" & LR), Order2:=xlAscending, Header:=xlYes End Sub دا الكود اللي هيرتب الذكور ثم الإناث ، وبعدين يرتب الأسماء ، في النطاق اللي بيبدأ من A1:C ورقم آخر صف ..لاحظ إننا شلنا رقم 20 من الكود الأصلي اللي شرحناه من بدري ، واستبدلناه بالمتغير LR والذي يحمل قيمة رقم آخر صف...!! لتجربة الكود أضف اسماً جديدا ونفذ الكود مرة أخرى ستجد أن الاسم الجديد قد انتقل لترتيبه ، وإلى هنا توقفت دماغي (فااااااااااااااصل ومفيش نواصل) أرجو أن أكون قد وفقت في توصيل المعلومة ، وإلى أن نلتقي أترككم في رعاية الله. كان معكم الحاجة أم محمد صاحبة الفطير من منتدى أوفيسنا تقبلوا تحياتي ودمتم بود

Bak2.rar

السلام عليكم أخي العزيز صيغة CSV كما قال الغالي أبو أحمد إن لم يقبل جهازك هذه الصيغة فلتلجأ للصيغة الأخري VCF وهذه الاخيرة تحتاج خطوات أكثر ويلزم أن يكون عندك برنامج أوتلوك ستنقل محتويات الأسماء بالأوتلوك إلي مكان آخر مؤقت ثم تستورد إلي الأوتلوك من الملف الإكسل أو الـCSV ثم من الأوتلوك يمكنك إرسال جميع الأسماء إلي صيغة VCF إلغي الأسماء من الأوتلوك وإسترجع أسماء الأوتلوك الأصلية لمكانها مرة أخري في الخطوة 4 ،يلزمك كود صغير علي الأوتلوك وليس علي الإكسل ليمكن الأوتلوك من إرسال جميع الأسماء إلي صيغة VCF وليس إسما بإسم كما هو العادي هذا الكود هو Sub Save_all_Contacts_as_VCF_format() Dim ns As NameSpace Dim foldContact As Folder Dim itemContact As ContactItem Dim colItems As Outlook.Items Dim myProperty As Outlook.UserProperty Set ns = Application.GetNamespace("MAPI") Set foldContact = ns.GetDefaultFolder(olFolderContacts) Set colItems = foldContact.Items.Restrict("[MessageClass]='IPM.Contact'") For Each itemContact In colItems i = i + 1 itemContact.SaveAs "D:\AAA\" & i & ".vcf", olVCard Next End Sub ستلاحظ كما بالسطر قبل الأخير بالكود itemContact.SaveAs "D:\AAA\" & i & ".vcf", olVCard أنك لابد أن تكون مجهز قبل تشغيل الكود مجلد وليكن AAA علي الدرايف D إن أردت إرسل لي الملف مهما كان كبيرا وسأحوله لك بإذن الله