مختار حسين محمود

الله الله عليك يا أستاذى العزيز الموضوع جديد ومفيد توغل فيه من غير تعقيد تحياتى

أخى و أستاذى الغالى أباالبراء بارك الله فيك مشكور أستاذى على الاضافة الجميلة لكن الدالة Concat لما جربتها وجدت أنها تربط خلايا نطاق كامل و لا تنفع مع الخلايا المتباعدة ولا أنا مش واخد بالى

السلام عليكم أحبابى واخوانى فى المنتدى هذه أول مشاركة لى بالمنتدى بعد النسخة الجديدة واسمحوا لى بأن أعبر عن رأيى فيها باختصار مثل غالبية المنتديات الأجنبية التى أطلع عليها وأشارك فيها .الشكل يبدو جافا ومفيش حيوية ولا ألوان براقة أو صورة جذابة حتى شريط العناوين كان علامة مميزة لهذا المنتدى ويعطيه الحيوية والنشاط وللأسف افتقدها المنتدى فى ثوبه الجديد ومع أن ده مهم بالنسبة ليه على الأقل والمفروض يؤخذ شكل المنتدى فى الاعتبار كجاذب للتعلم لكن الأهم أننا نتعلم و ربنا يجعل قيها البركة ويحببنا فيها أكتر من القديمة موضوعى الجديد باختصار هو ربط مجموعة خلايا ببعضها فى خلية واحدة يعنى ببساطة لو عندى مجموعة خلايا أقدر أضمهم فى واحدة بدون دمج للخلايا وأنتم عارفين دمج الخلايا الكود وعليه شرح بالعربية : Sub JoinCells() Dim Rng As Range, C As Range, FC As Range, SS As String, Rep As Integer On Error Resume Next ' فى حالة حدوث خطأ يتم تخطيه للنقطة التالية 'جعل المستخدم يعين أو يحدد الخلايا المراد ربطها Set Rng = Application.InputBox(Prompt:=" Ctrl' لربط الخلايا الغير متجاورة " & " استخدم المفتاح ", Title:="سلسلة الخلايا", Type:=8) If Rng Is Nothing Then ' فى حالة عدم فى تحديد أى خلايا Rep = MsgBox(" ! تم الغاء عملية الربط ", vbQuestion + vbRetryCancel) ' رسالة If Rep = vbCancel Then ' فى حالة الغاء تحديد الخلايا On Error GoTo 0 ' فى حالة حدوث خطأ تتم العودة الى نقطة الصفر Exit Sub ' و يتم الخروج من الاجراء Else ' اذا لم يلغى المستخدم عملية تحديد الخلايا Run "JoinCells" ' يتم اعادة الاجراء من جديد End If ' انتهاء جملة الشرط End If ' انتهاء جملة الشرط Set FC = Rng(1, 1) ' اعتبار أول خلية فى الخلايا المحددة كخلية رئيسية تتجمع فيها نصوص باقى الخلايا For Each C In Rng ' عمل لوب على كل الخلايا المراد ربطها SS = C ' اعتبار قيمة المتغير نصا و تساوى قيم الخلايا المحددة C.Clear ' تفريغ محتوى الخلية FC = Trim(Replace(FC, FC, "") & " " & FC & " " & SS) 'استبدال المحتوى الأصلى لأول خلية بالنصوص التى فى الخلايا Next C End Sub ' انتهاء الاجراء وهذا هو المرفق Join selection Cells .rar وهذا شكل آخر للكود Sub JoinCells() Dim Rng As Range Dim C As Range Dim FC As Range Dim StrStart As String Set Rng = Sheets("Sheet1").Range("C10,E10,G10,I10") Set FC = Sheets("Sheet1").Range("C4") 'مكان تجميع الخلايا For Each C In Rng StrStart = C C.ClearContents 'OR : Clear FC = Trim(Replace(FC, FC, "") & " " & FC & " " & StrStart) Next C End Sub وهذا مرفق على الشكل الثانى للكود Join specific Cells mokhtar .rar

أشكرك أخى الفاضل أيمن

أخى الكريم ياسر بارك الله فيك وجازاكم خيرا طورت الكود بحيث يتم إنشاء مصنف لكل توجيه ويستثنى "بدون توجيه" ، كما يستثنى "بدون توجيه" في مصنف "قوائم التوجهات الكلية" ويصبح الكود بهذا الشكل : Sub MOKHTARTSET2() Dim myDir As String, C As Range, WB As Workbook, NWB As Workbook, Rng1 As Range, Rng2 As Range Set WB = ThisWorkbook myDir = ActiveWorkbook.Path & "\" & "My Workbook" Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next MkDir myDir On Error GoTo 0 '--------------------------------------------------------------------------------- WB.Sheets("Final").Select Range("D7:S7").Select Selection.AutoFilter ActiveSheet.Range("$D$7:$S$27").AutoFilter Field:=16, Criteria1:="<>بدون توجيه", Operator:=xlAnd Columns("F:Q").Select Selection.EntireColumn.Hidden = True Set Rng1 = WB.Sheets("Final").Range("d7:s27").SpecialCells(xlCellTypeVisible) Rng1.Select Selection.Copy Set NWB = Workbooks.Add ActiveSheet.Range("A4").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Range("A4:D24").Select With Selection .HorizontalAlignment = xlCenter .Font.Size = 10 .Font.Bold = True .Interior.ColorIndex = 38 .Borders.LineStyle = xlContinuous End With ActiveSheet.Range("B2") = "قـــــوائم التوجهـــــــات الكلـــــية " NWB.SaveAs Filename:=myDir & "\" & "قـــــوائم التوجهـــــــات الكلـــــية " & ".xlsx", CreateBackup:=False NWB.Close WB.Activate WB.Sheets("Final").Cells.Select Selection.EntireColumn.Hidden = False Selection.AutoFilter Range("X11").Select '-------------------------------------------------------------------------------------- For Each C In Sheets("Final").Range("U12:U23") WB.Sheets("Final").Range("AA1").Value = C.Value ' ------------------------------------------------------------------------------- WB.Sheets("Final").Activate Range("D7:S7").Select Selection.AutoFilter ActiveSheet.Range("$S$11:$S$27").AutoFilter Field:=16, Criteria1:="<>بدون توجيه", Criteria2:="=" & C.Value, Operator:=xlAnd Range("F:Q,S:S").Select Selection.EntireColumn.Hidden = True Set Rng2 = WB.Sheets("Final").Range("D7:R27").SpecialCells(xlCellTypeVisible) Rng2.Select Selection.Copy Set NWB = Workbooks.Add ActiveSheet.Range("A4").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Range("A4:D10").Select With Selection .HorizontalAlignment = xlCenter .Font.Size = 10 .Font.Bold = True .Borders.LineStyle = xlContinuous .Interior.ColorIndex = 38 End With ActiveSheet.Range("B2") = "الموجهون الى" ActiveSheet.Range("C2") = C.Value NWB.SaveAs Filename:=myDir & "\" & C.Value & ".xlsx", CreateBackup:=False NWB.Close WB.Activate WB.Sheets("Final").Cells.Select Selection.EntireColumn.Hidden = False Selection.AutoFilter Range("A1").Select '----------------------------------------------------------------------------------- Next C Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub أشكرك أستاذى العزيز . Pupils Distribution According To Marks & Wishees by mokhtar v2 .rar

الله الله عليك يا أبا البراء رائع هذا الكود رغم أن فيه شوية كلاكيع استفسار : ليه تم استثناء مصنف لــ "بدون توجيه" ، كما تم استثناء "بدون توجيه" في مصنف "قوائم التوجهات الكلية" مع أن من المفروض أن يعامل غير الموجهين كغيرهم فهم جزء من الكل ولا ده طلب لأخونا أشرف .دى نقطة النقطة الثانية فى ملف أخونا أشرف وضع أسماء التوجهات النهائية فى النطاق "U12:U23" وفيهم التوجه التسويق 3 مع أنه مش موجود فى العمود S وأنا فى كودى اعتمدت على هذا النطاق لعمل مصنف لكل توجه موجود بهذا النطاق وبالتالى فى مخرجات كودى طلع مصنف التسويق 3 فارغ بدون أسماء ليه ؟؟؟؟؟؟؟؟؟؟؟؟؟ لأن أصلا مفيش حد تم توجيهه الى التسويق 3 وأخوك ضليع جدا فى المعادلات وعايز معادلة فى النطاق "U12:U23" تاخذ من العمود S أسماء التوجهات النهائية بدون تكرار وتستثنى بدون توجيه وبكده لا يظهر فى مخرجات كودى أى مصنف فارغ ياريت أكون واضح فى طلبى تحياتى لك

السلام عليكم ورحمة الله وبركاته أستأذن أخى وأستاذى العزيز ياسر خليل وأشارككم بهذه المحاولة التى أعتبرها بداية جيدة أتفق مع رأى أستاذى العزيز ياسر الأخير بالمشاركة 9 حيث يتم تصدير كل توجيه الى مصنف مستقل ويتم تصدير كل التوجيهات الى مصنف عام يجمع الكل فهو الأيسر والأسهل والأقرب الى الصواب فبدلا من أن يكون هناك زر أمر لكل توجيه على حدا وأكواد متعددة يكفى زر واحد وكود واحد يقوم بذلك : الكود : Sub MOKHTARTSET() Dim myDir As String, C As Range, WB As Workbook, NWB As Workbook, Rng1 As Range, Rng2 As Range Set WB = ThisWorkbook myDir = ActiveWorkbook.Path & "\" & "My Workbook" Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next MkDir myDir On Error GoTo 0 '--------------------------------------------------------------------------------- WB.Sheets("Final").Select Columns("F:Q").Select Selection.EntireColumn.Hidden = True Set Rng1 = WB.Sheets("Final").Range("d7:s27").SpecialCells(xlCellTypeVisible) Rng1.Select Selection.Copy Set NWB = Workbooks.Add ActiveSheet.Range("A4").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Range("A4:D24").Select With Selection .HorizontalAlignment = xlCenter .Font.Size = 10 .Borders.LineStyle = xlContinuous End With ActiveSheet.Range("B2") = "قـــــوائم التوجهـــــــات الكلـــــية " NWB.SaveAs Filename:=myDir & "\" & "قـــــوائم التوجهـــــــات الكلـــــية " & ".xlsx", CreateBackup:=False NWB.Close WB.Activate WB.Sheets("Final").Cells.Select Selection.EntireColumn.Hidden = False Range("X11").Select '-------------------------------------------------------------------------------------- For Each C In Sheets("Final").Range("U12:U23") WB.Sheets("Final").Range("AA1").Value = C.Value ' ------------------------------------------------------------------------------- WB.Sheets("Final").Activate Range("D7:S7").Select Selection.AutoFilter ActiveSheet.Range("$D$7:$S$27").AutoFilter Field:=16, Criteria1:="=" & C.Value, Operator:=xlAnd Range("F:Q,S:S").Select Selection.EntireColumn.Hidden = True Set Rng2 = WB.Sheets("Final").Range("D7:R27").SpecialCells(xlCellTypeVisible) Rng2.Select Selection.Copy Set NWB = Workbooks.Add ActiveSheet.Range("A4").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Range("A4:D10").Select With Selection .HorizontalAlignment = xlCenter .Font.Size = 10 .Borders.LineStyle = xlContinuous End With ActiveSheet.Range("B2") = "الموجهون الى" ActiveSheet.Range("C2") = C.Value NWB.SaveAs Filename:=myDir & "\" & C.Value & ".xlsx", CreateBackup:=False NWB.Close WB.Activate WB.Sheets("Final").Cells.Select Selection.EntireColumn.Hidden = False Selection.AutoFilter Range("A1").Select '----------------------------------------------------------------------------------- Next C Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub الكود ينتج عنه الملفات المطلوبة داخل مجلد باسم My Workbook فى مسار الملف أرجو أن يكون هو المطلوب. Pupils Distribution According To Marks & Wishees by mokhtar .rar

Sub FilterthenPDFcellvalue() ' التصريحات Dim Rng As Range Dim fName As String ' اسم ومسار الملف المتوقع انشاؤه fName = "D:\" & ActiveSheet.[E2].Value 'الغاء خاصية اهتزاز الشاشة Application.ScreenUpdating = False With Sheets("كشف الحساب ") 'فلترة للنطاق .AutoFilterMode = False ' .Range("D4:S5").AutoFilter Field:=1, Criteria1:="<>" ' تحديد النطاق المستخدم فى الشيت كشف الحساب والذى سيتم تحويله الى بى دى اف Set Rng = Sheets("كشف الحساب ").Range(Cells(1, 4), Cells(Rows.Count, 19)) 'تنشيط النطاق Rng.Activate 'تحويل النطاق المفلتر الى بى دى اف Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fName, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False 'نحديد شيت كشف الحساب .Select ' الغاء الفلترة واظهار كل النطاقات المعبئة بالبيانات والفارغة .Cells.AutoFilter ' الغاء تحديد أى نطاق باختيار الخلية D2 Range("d2").Select End With 'تشغيل خاصية اهتزاز الشاشة Application.ScreenUpdating = True End Sub

السلام عليكم ورحمة الله أستاذى الفاضل بن عليه حاجى كل سنة وحضرتك طيب حل رائع من أستاذ أروع أخى صلاح جرب هذا المرفق تم فيه استعمال خاصية الفلترة ثم عمل الـ pdf كما طلبت فى مشاركتك الكود Sub FilterthenPDFcellvalue() Dim Rng As Range Dim fName As String fName = "D:\" & ActiveSheet.[E2].Value Application.ScreenUpdating = False With Sheets("كشف الحساب ") .AutoFilterMode = False .Range("D4:S5").AutoFilter Field:=1, Criteria1:="<>" Set Rng = Sheets("كشف الحساب ").Range(Cells(1, 4), Cells(Rows.Count, 19)) Rng.Activate Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fName, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False .Select .Cells.AutoFilter Range("d2").Select End With Application.ScreenUpdating = True End Sub المرفق Hide Blank Rows Using AutoFilter then pdf mokhtar .rar

مشكور أخى ياسر على الهدية القيمة والجميلة أيضا بارك الله فيك وجزاك الله خير الجزاء

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

أخوتى وأساتذتى ياسر فتحى وياسر خليل و سليم حاصبيا بارك الله فيكم وجازاكم خيرا أخى وأستاذى ياسر خليل بدون مجاملات الأكواد المضافة أكثر من رائعة وغاية فى الرقى وأنت من علمنى الحرص على أن يكون الكود يجمع بين البساطة والدقة والسرعة والمرونة والاختصار جازكم الله عنى وعن تلاميذك خيراً واليك هذه الاضافة أيضا تؤدى نفس الوظيفة بدون اللجوء إلى استخدام طريقة النسخ كما هو الحال فى كودك الثانى بالمشاركة 4 Sub mokhtest3() Sheets("مستودع").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 6).Value = Sheets("بيانات").Cells(ActiveCell.Row, 1).Resize(1, 6).Value End Sub تحياتى

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

السلام عليكم جميعا أخى وأستاذى ياسر و أخى الأستاذ خالد وأخى الأستاذ محمد حسن لكم كل التحية والتقدير والاحترام وجازاكم خيرا الأخ على الرويلى طالما الموضوع انتهى كان يجب أن تضع طلبك الأخير فى موضوع جديد لعموم الفائدة لذلك بدون طرح طلبات جديدة تفضل هذا الموضوع خاص بطلبك الأخير وهو نسخ صف الخلية النشطة http://www.officena.net/ib/index.php?showtopic=62821#entry407342 تحياتى لأساتذتى واخوانى وأحبابى

الأخوة والأساتذة الكرام طلب أحد الأخوة نسخ الخلية النشطة مع صفها من شيت الى شيت آخر فى هذا الرابط http://www.officena.net/ib/index.php?showtopic=62805 ولعموم الفائدة أضع بين أيديكم كود نسخ الخلية النشطة وبعدها عدد محدد من الخلايا وليكن 5 خلايا مثل النسخ من A5 الى F5 Sub mokhtest2() Application.ScreenUpdating = False ActiveCell.Resize(1, 6).Copy Sheets("مستودع").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) ' لنسخ ولصق النشطة بالفورمات وبعدها 5 خلايا Application.ScreenUpdating = True Application.CutCopyMode = False End Sub الجزئية ActiveCell.Resize(1, 6).Copy معناها نسخ الخلية النشطة مع 5 خلايا بعدها فى نفس الصف وده = 6 الجزئية Sheets("مستودع").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) هى وجهة اللصق أول فارغة فى العمود 1 فى الشيت مستودع واللصق يكون للقيم والفورمات باقى الكود للتسريع وتفريغ الذاكرة العشوائية المرفق copy row based on ActiveCell mokhtar .rar

أخى الحبيب على جرب الكوداية دى Sub mokhtest() ActiveCell.Copy Sheets("مستودع").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) End Sub معنى الكود انسخ الخلية النشطة والصق فى أول خلية فارغة بالعمود 1 بورقة العمل مستودع بس خلاص حدد الخلية واضغط الزر هتلاقيها فى الشيت مستودع ولو حبيت تضيف خلايا أخرى براحتك تحياتى

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

الله عليك يا أستاذ سليم بالفعل أنت ملك من ملوك المعادلات

السلام عليكم أخى الفاضل ziso 777 حبذا لو غيرت اسمك الى اللغة العربية طبقا لتعليمات المنتدى أخى الكريم راجع الرابط التالى فله علاقة مباشرة بطلبك http://www.officena.net/ib/index.php?showtopic=62799

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

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

السلام عليكم اخوانى وأساتذتى فى المنتدى وكل عام وأنتم بخير بمناسبة عيد الفطر اليوم أقدم لكم كيفية عمل اختصار لملف اكسل به صورتك على سطح المكتب فقد لفت نظرى طلب أحد الأخوة لهذا الموضوع لذلك قررت أن أضع بين أيديكم الطريقة الآتية 1 - فى ملف اكسل أدرج هذا المديول Option Explicit Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long Private Declare Function CloseClipboard Lib "user32" () As Long Private Declare Function GetActiveWindow Lib "user32" () As Integer Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName 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 Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hWnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Const CSIDL_PERSONAL = &H5 Private Type SHITEMID cb As Long abID As Byte End Type Private Type ITEMIDLIST mkid As SHITEMID End Type Dim FSO As New FileSystemObject Dim FLD As Folder Function UserNameOffice() As String UserNameOffice = Application.UserName End Function Public Function DesktopAddress() As String DesktopAddress = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator End Function Private Function GetSpecialFolder(CSIDL As Long) As String Dim Path As String Dim FolderPath As Object Dim IDL As ITEMIDLIST Dim sh As New Shell32.Shell Set FolderPath = sh.NameSpace(5) If Not FolderPath Is Nothing Then GetSpecialFolder = FolderPath.Self.Path Exit Function End If GetSpecialFolder = "" End Function Function DirExists(strDirectory As String) As Boolean DirExists = (Dir(strDirectory, vbDirectory) <> "") End Function Sub Desktop_Shortcut() Dim WBName As String, Path As String, WB_Link As String, WB_Name As String Dim DesktopPath As String, TargetPath As String, StrSave As String Dim WSHShell As Object, MyShortcut As Object Set WSHShell = CreateObject("WScript.Shell") Dim FSO As Object, Folder As Object, File As Object Set FSO = CreateObject("Scripting.FileSystemObject") Dim WB As Workbook Set WB = ThisWorkbook Dim WSh As Worksheet Set WSh = Sheet1 WBName = WB.Name Path = "MyFile" DesktopPath = WSHShell.SpecialFolders("Desktop") WSh.Range("C2").Value = WB.Name WB_Name = WSh.Range("C3").Value WB_Link = WSh.Range("C4").Value On Error GoTo ErrHandle If Not DirExists("C:\" & WB_Name) Then 'Check C Drive If Not DirExists(GetSpecialFolder(CSIDL_PERSONAL) & "\" & WB_Name) Then 'Check My Documents Set FSO = CreateObject("Scripting.FileSystemObject") 'If not in C Drive or My Documents - then create shortcut FSO.CreateFolder "C:\" & WB_Name ChDir "C:\" & WB_Name SavePicture Sheet1.Image1.Picture, WB_Name & ".ico" 'Picture pasted onto Image1 on Sheet 1 - Link Shortcut Set FSO = CreateObject("Scripting.FileSystemObject") Set MyShortcut = WSHShell.CreateShortcut(DesktopPath & "\" & WB_Link) With MyShortcut .TargetPath = WB.FullName .IconLocation = "C:\" & WB_Name & "\" & WB_Name & ".ico" .WindowStyle = 1 .Description = "EEZIAdmin" .WorkingDirectory = WB.Path .Save End With Else End If End If ErrHandle: Set WSHShell = Nothing End Sub 2 - فى شيت 1 الخلية C3 ضع المعادلة =IF($C$2="";"";IF(MID($C$2;(LEN($C$2)-4);"1")=".";LEFT($C$2;LEN($C$2)-5);IF(MID($C$2;(LEN($C$2)-3);"1")=".";LEFT($C$2;LEN($C$2)-4);""))) وفى الخلية C4 ضع المعادلة الآتية =IF($C$3<>"";$C$3&".lnk";"") 3 - فى شيت 1 ادراج Image وعليها صورة : ندرج الـ Image كالتالى من developet tab ثم insert ثم more controls ثم Microsoft forms 2.0 image ثم ok ارسم الـــــ Image فى الشيت وبعدين كليك يمين عليها واخنر Properties فى قائمة الخصائص التى تظهر دور على الخيار Picture واعمل ادراج لأى صورة من على جهازك على الـ Image واحفظ وشغل الكود لكم كل التحية والتقدير Desktop Shortcut mokhtar.rar

أخى وأستاذى العزيز ياسر خليل دائما بصمتك فى الأكواد رائعة .وده هو اللى محببنى فيك الأخ الحبيب Creation World أشكرك لكونك تتنازل عن الاسم الغالى ده عليك لكن للمنتدى قواعد يجب الالتزام بها حتى يسهل على باقى الأعضاء الاشارة الى اسمك ولا تنسى قفل الموضوع طالما توصلت للحل وختى لا يخرج الموضوع عن طبيعته أخى الفاضل الميسانى حتى لو وصل عدد الطلاب الى 2000 طالب لن يزيد الملف الزيادة اللى مخوفاك دى تم تنفيذ رغبتك وطلبك فى المشاركة 19 لأنها تدخل فى اطار الموضوع الأصلى والموضوع الأصلى تقريبا انتهى لذلك أية طلبات جديدة ضعها فى موضوع جديد تحدد فيه طلبك . كل عام وأنتم جميعا بخير وأقرب الى الله

أخى الحبيب حمل المرفق التالى بعد فك الضغط هتلاقى ملف اكسل ضع ملف الاكسل فى المسار بتاعك C:\Program Files (x86)\Microsoft Office\Office14\XLSTART داخل مجلد XLSTART افتح أى ملف الاكسل وافتح الفيجوال بيسك هتلاقى فيه كود hide_toolbar هو اللى أنا وضعته فى الملف test افتح ملف اكسل تانى وافتح الفيجوال بيسك هتلاقى فيه الكود hide_toolbar أيضا وهكذا يمكن أن نقول على الكود ده دائم لأنك ممكن تستعمله مع أى ملف أرجو أن تكون فهمتنى تحياتى TEST.rar

اخي العزيز علي الشيخ وأبا حنين كل عام وانتما بالف خير و جزاكم الله خيرا الرابط http://www.officena.net/ib/index.php?showtopic=62373 مشاركة 19 خاصة مفيدة لحفظ كل الشهادات في ملف واحد