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

الأخوة والأساتذة الكرام طلب أحد الأخوة نسخ الخلية النشطة مع صفها من شيت الى شيت آخر فى هذا الرابط 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

لتعم الفائدة والإستفادة للجميع شرح دوال الاكسيل.rar

السلام عليكم ورحمة الله وبركاته مكتبة تحتوى على العديد من الكتب فى لغات البرمجه http://kutub.info/library/category/1

أرجوا أن ينال رضا الجميع وكل عام وأنتم بخير تقبلوا خالص تحياتى Excel Formulas.rar

اخواني في المنتدى لماذا لا تدعون المستخدم يختار عدد الصفوف و الاعمدة المطلوبة ابتذاءً من الخلية المحددة (بدل ان يدخل الى الكود و يقوم بهذا الشيء) عبر هذا الكود Sub CopyRowActiveCell() Dim WS As Worksheet, SH As Worksheet, LR As Long Set WS = Sheets("Sheet1"): Set SH = Sheets("Sheet2") LR = SH.Cells(Rows.Count, 1).End(xlUp).Row myrow = Application.InputBox("حدد عدد الصفوف", Default:=1) mycol = Application.InputBox("حدد عدد الاعمدة", Default:=1) ActiveCell.Resize(myrow, mycol).Copy SH.Cells(LR + 1, 1).PasteSpecial (xlValues) Application.CutCopyMode = False End Sub

أو يمكن استخدام هذا الكود بدون اللجوء إلى استخدام طريقة النسخ أو الحلقات التكرارية Sub CopyRowActiveCell() Dim WS As Worksheet, SH As Worksheet, LR As Long Set WS = Sheets("بيانات"): Set SH = Sheets("مستودع") LR = SH.Cells(Rows.Count, 1).End(xlUp).Row + 1 SH.Cells(LR, 1).Resize(1, 6).Value = WS.Cells(ActiveCell.Row, 1).Resize(1, 6).Value End Sub

جرب هذا الكود Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Not Intersect(Target, Range("g14")) Is Nothing Then m = Target.Value n = Target.Offset(1, 0).Value + m Target.Offset(1, 0) = n Target.Value = "" Target.Select Application.EnableEvents = True End If Application.EnableEvents = True End Sub

بارك الله فيك أخي الحبيب مختار إليك كود آخر لا يرقى لمستوى كودك بالطبع ..فكودك هو الأيسر والأسهل Sub CopyRowActiveCell() Dim WS As Worksheet, SH As Worksheet Dim lrWS As Long, lrSH As Long, I As Long Set WS = Sheets("بيانات"): Set SH = Sheets("مستودع") lrWS = ActiveCell.Row lrSH = SH.Cells(Rows.Count, 1).End(xlUp).Row + 1 For I = 1 To 6 SH.Cells(lrSH, I) = WS.Cells(lrWS, I) Next I End Sub

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

السلام عليكم الأخ الكريم فتحى سلام ... لقد تحول الموضوع بفضلك من مشكلة تبحث لها عن حل الى حوارات المخطئ و المصيب فينا و قيل و قال و أقصد و لغة عربية و علمى متأدب و تفرعنا من نقطة لأخرى لا تصب فى مصلحة الموضوع .. كلنا أخوة ندافع عن بعضنا البعض العادل فينا ندعمه و الظالم فينا نقومه و يا سيدى أنا المخطئ و حقك علي ، فالنعد للموضوع الأساسي يرجى موافاتنا بقدر مناسب من البيانات للعمل عليه ( راجع المشاركتين 2 و 3 ) ..لو كنا بالفعل نستخف بك ما إعطيناك إهتمام .. و لكن كما ترى الجميع يسارعون فى مساعدة بعضهم البعض .. و نحن هنا بإنتظار مزيد من التوضيح لطلبك دمت بخير و اعزك الله

بسم الله والصلاة السلام على رسول الله وعلى آله وصحبه ومن والاه أما بعد: السلام عليكم أساتذتي الكرام... لقد رأيت كتابة مشاركة الأخ أبو صاصا المحترم في المشاركة 8 حسن الكلام ورجاحة العقل والكلمات الموزونة لذلك تبادر إلى ذهني السؤال التالي: لم تسرع في البداية وأطلق أحكاماً جائرة فكلمة جانبك الصواب وإن كانت أخف وطئاً من كلمة أخطأت إلا أنها تؤدي إلى النتيجة ذاتها ...فليكن حسن الظن وإعذار الطرف الآخر سائداً بين الكل فنحن نتواصل بالكلمة وتعلمون أن الله تعالى أثنى على الكلمة الطيبة وذم تلك الخبيثة بقوله تعالى:﴿ أَلَمْ تَرَ كَيْفَ ضَرَبَ اللَّهُ مَثَلًا كَلِمَةً طَيِّبَةً كَشَجَرَةٍ طَيِّبَةٍ أَصْلُهَا ثَابِتٌ وَفَرْعُهَا فِي السَّمَاءِ (24) تُؤْتِي أُكُلَهَا كُلَّ حِينٍ بِإِذْنِ رَبِّهَا وَيَضْرِبُ اللَّهُ الْأَمْثَالَ لِلنَّاسِ لَعَلَّهُمْ يَتَذَكَّرُونَ (25) وَمَثَلُ كَلِمَةٍ خَبِيثَةٍ كَشَجَرَةٍ خَبِيثَةٍ اجْتُثَّتْ مِنْ فَوْقِ الْأَرْضِ مَا لَهَا مِنْ قَرَارٍ (26) يُثَبِّتُ اللَّهُ الَّذِينَ آَمَنُوا بِالْقَوْلِ الثَّابِتِ فِي الْحَيَاةِ الدُّنْيَا وَفِي الْآَخِرَةِ وَيُضِلُّ اللَّهُ الظَّالِمِينَ وَيَفْعَلُ اللَّهُ مَا يَشَاءُ (27) ﴾ ] سورة إبراهيم الآية:24-27 [في بعض الأحاديث الشريفة)) : الكلمة الطيبة صدقة] ((أخرجه مسلم وابن خزيمة في صحيحه عن أبي هريرة [ ))إن الرجل ليتكلم بالكلمة -من رضوان الله تعالى-, يرقى بها إلى أعلى عليين, وإن الرجل ليتكلم بالكلمة -من سخط الله تعالى-, يهوي بها إلى أسفل سافلين(( ورد في الأثر [ البطولة أن تعد كلامك من عملك, فالكلمة الطيبة صدقة, والكلمة الخبيثة يهوي بها الإنسان إلى أسفل سافلين. وكل ابن آدم خطاء...فليبحث كل منا عن عذر لصاحبه ...ألا تحبون أن يغفر الله لكم...فليغفر كل منا زلة صاحبه ..فلسنا بمعصومين وهنا أقول كلا مي ناصحاً بذلك نفسي بداية وكل من يقرأ كتابتي هذه أنتم كلكم خير مني ولكن أرى نفسي محباً لنصح إخوتي ليبقى قلب كل منا سليم باتجاه إخوته...ولنتمسك بسيد الأخلاق لأننا نعيش حياة عبور لا تستحق منا أن نعرض عن بعضنا فإن لاقى كلامي هذا قبولاً منكم فلله الفضل والمنة وإن كان غير ذلك فإنني أعتذر تقبلوا مروري واحترامي والسلام عليكم ورحمة الله وبركاته..أخوكم أبو يوسف...

الأساتذة الكرام ياسر خليل أبو البراء وخالد الرشيدي ومختارحسين محمود المحترمين السلام عليكم ورحمة الله وبركاته.. أعمالكم كلها جيدة ورائعة ومميزة ...كلها تصب ببوتقة واحدة ولذلك أراها كلها رائعة ولا أقول إلا جزاكم الله خيراً..وكلها موضع إعجاب. تقبلوا تحياتي واحترامي... والسلام عليكم ورحمة الله وبركاته..

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

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

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

السلام عليكم و رحمة الله و بركاته اخواني و اساتذتي رواد منتدانا الغالي كل عام و انتم و الامه الاسلاميه بخير و صحة و عافيه و عيدكم مبارك هديتي متواضعه كعلمي و ارجو من الله ان يكون بها فائدة لاخواني المبتدئين على وجه الخصوص برنامج المعاملات : يقوم بحفظ بيانات المعاملات و من ثم يتم تصنيف المعاملات الى 6 فئات 1: منجزة تحت الاجراء : لم تتجاوز الثلاثة ايام و ينطبق على الفئة الرابعة 2: منجزة متأخرة : ما بين 4 الى 10 ايام و ينطبق على الفئة الخامسة 3: منجزة متأخرة جداً : اكثر من 10 ايام و ينطيق على الفئة السادسة 4: غير منجزة تحت الاجراء : 5: غير منجزة متأخرة 6: غير منجزة متأخرة جداً - تدوين كامل بيانات المعاملة واضافة اكثر من مرفق للمعاملة الواحدة و تصفح المرفقات ( يتم فك الضغط عن الملف بالدرايف C و حفظ جميع صور المعاملات المراد استعراضها من البرنامج بالملف Photos و يمكن تغيير المسار بالدخول على الكود ) علماً بأن الصور فقط بالامتداد JPEG - هناك عملية متابعه يتم من خلالها عرض المعاملات الغير منجزة و عرض تقرير بها - تقرير يشتمل على رسوم بيانيه للاحصاء و المقارنة يوضح النسبة المئويه لعدد المعاملات المنجزة لجهة او اربعة جهات كحد اقصى كما يوجد احصاء لجميع المعاملات المنجزة و الغير منجزة ( تقريرين حسب نوع المقارنة ) - ارسال بريد الكتروني لجميع المعاملات التي لم تنجز في اكثر من 3 ايام و تدوين تاريخ و وقت ارسال الايميل تلقائي - التحكم في نص الرسالة و و عنوانها و الجهة المراد ارسال نسخة من البريد اليها - صلاحيات للمستخدمين تتكون من مستويين : 1: كامل الصلاحيات : و بتحديدها يتم الدخول على كامل البرنامج 2: صلاحية محدودة : وفيها فقط يتم استعراض السجلات و عمل الاحصائيات و المقارنات 3: تحديد كامل الصلاحية او الصلاحية المحدودة يتم من خلال مربع اختيار CheckBox 4: شاشة لمتابعة دخول و خروج المستخدمين ليتابعها المسئول مع ملاحظة بأن سجلات هذا الجدول ستكون في ازدياد بعدد مرات الدخول الى البرنامج و ينصح بشدة التخلص منها و حذفها في حالة عدم الحاجة اليها . البرنامج مفتوح و بدون الشفت او اخفاء الاكسس ايضاً ليتمكن اخواني المبتدئين من الاستفادة من الاكواد الموجودة فيه اسأل الله عز و جل التوفيق للجميع اخوكم : يوسف Documentation.rar

السلام عليكم اخوانى وأساتذتى فى المنتدى وكل عام وأنتم بخير بمناسبة عيد الفطر اليوم أقدم لكم كيفية عمل اختصار لملف اكسل به صورتك على سطح المكتب فقد لفت نظرى طلب أحد الأخوة لهذا الموضوع لذلك قررت أن أضع بين أيديكم الطريقة الآتية 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

السادة الأفاضل أعضاء وأساتذة وعمالقة هذا المنتدى العظيم الرائع الذى تعلمت وإستفدت منه الكثير والكثير كل عام وحضراتكم بألف صحة وسلامة أقدم لكم اليوم ملف لعله يفيد سيادتكم الرجاء النظر مع إبداء الرأى أرجوا أن ينال رضا الجميع Advance Excel Function Training.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 تحياتى

جزيت خير الجزاء أخي الحبيب الغالي ياسر فتحي تقبل الله منا ومنكم وعوداً حميداً

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

بارك الله فيك وفي عملك

اخى م/ياسر فتحى ملف ممتاز ولكن شكوة اخى ياسر اشكو انا منها لو خط معين غيرت الخط

كشفت عن اللغة طلعت تايلاندي ..!!!! وأنا يدوب ثقافتي شوية عربي

لابد من ضبط هذه الامور في الاساسات في الجداول تم اضافة رقم معرف للدرجة داخل الجدول انظر التقرير الآن : يتم الفرز اولا حسب الدرجة وثانيا حسب الاسم وكل هذا عن طريق ما يسمى بالفرز واتجميع New Microsoft Access Database.rar

تم التطبيق داخل الاستعلام في حقل جديد آمل ان يحقق مطلوبك DB_4.rar

الأخ الكريم كل عام وأنت بخير طلبنا منك مراراً تغيير اسم الظهور للغة العربية بالنسبة لطلبك جرب استخدام دالة Sumif شوف الملف المرفق هل يؤدي بالغرض أم لا؟ مجمع وأوراق 2.rar

كل عام وانتم بخير اولا ثانيا : اضف السطر الجديد للكود خلف زر تحديث ليصبح كالتالي : Private Sub أمر33_Click() If MsgBox("تاكيد العملية ؟ ", vbYesNo) = vbNo Then Undo DoCmd.Requery End Sub بالتوفيق

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

فك____رة 12 الاخوة الكرام فكرة اليوم كنت قد وضعتها فى وقت سابق على المنتدى ولكنى سأضعها ايضاً فى هذا الموضوع لكى يكون مجمع لكافة حالات الدالة قدر الامكان 12.rar ......................................... هذا الكود بسيط فقط ل -المعرفة المبدئية - بقى الان الملف المجمع لكافة الحالات وبة ستجدون باقى الافكار ان شاء الله

ربما كان المطلوب !مجمع و اوراق.zip

أخي أيمن أقواس الكود تكون بهذا الشكل <> انقر هذه العلامة <> ثم الصق ما تريده من معادلات وأكواد بداخلها لتظهر مثل هذا الشكل

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

الكود يعمل تماماً استاذى ياسر لم اجرب ذلك .. قمت فقط بنسخ الكود ولصقة ليكون هناك مرفق لكود الاستاذ مختار ثم لاحظت النتائج ولم ارجع الى الكود ثانية جزاك الله خيراً اخى الكريم اليك ملف اخر بهذا الكود المبسط فية يتم ترحيل القيمة مختار حسين.rar .................................................... الان اصبح لديك 4 اكواد اختر منهم ما يناسبك

استاذن أ.مختار فى تقديم طرق اخرى لاثراء الموضوع اخى الكريم اليك ثلاثة ملفات احدهما يتم تطبيق الكود بمجرد تحديد اى خلية فى العمود A الثانى يتم الترحيل بتحديد الخلية المراد ترحيلها فى العمود A ثم الضغط على زر ترحيل يجدر الاشارة الى ان معادلة الاستاذ مختار هى الاسهل فى التطبيق ولكنها تقوم بنقل الخلية بجميع تنسيقاتها وان كانت بها معادلة سيتم ترحيل المعادلة ايضاً اما الملفين الاخرين يتم ترحيل القيمة فقط وستجد تطبيقها ضمن الملفات 3 مع اضافة ان شرط للترحيل وهو ان تكون الخلية فى العمود A - بعد اذن استاذى مختار طبعاً - El Rashedy.rar ............................................................. اخى الفاضل هذه المشاركة لاثراء الموضوع لذا قم بتحديد مشاركة الاستاذ مختار كأفضل إجابة

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

بص بقا صورتك الجميلة دي زهقتني ... أنا حذفت الاختصارات من على سطح المكتب ومن على الدرايف C وغيرت صورتك لصورتي اللي باين عليها الإكسيل مش قابلها ونفذت الأمر لقيت صورتك بردو :wallbash: المهم قلت مبدهاش لازم أعمل حاجة عملت كليك يمين على الاختصار لقيت Change Icon نقرت عليها وأنا متغاااااظ .. المفاجأة لقيت الأيقونة الخاصة بالصورة بتاعتي اختارتها وفلحت .. بس أسلوب العافية ده مش بحبه عايز أعرف السبب في عدم التغيير بشكل مباشر للصورة الجديدة

الأخ أحمد الطحان هل المطلوب تم على خير ..لم تذكر ولم تشر إلى ذلك الأمر الأخ الحبيب سليم والأخ الغالي مختار والأخ المتميز ياسر فتحي مبارك الترقية المستحقة عن جدارة بارك الله فيكما وجمع الله بيننا في الفردوس الأعلى من الجنة (قولوا آمين) تقبلوا تحياتي وكل عام وأنتم بخير

مخطئ تماما أيها الأخ الكريم أبو صاصا و كلامك مردود عليه أولا : لم تراعى قواعد المشاركة فى الموقع http://www.officena.net/Tips/Questions.htm خمسة دقائق لن تكلفك الكثير و ستريحك فى التعامل مع الموقع بشكل صحيح و فعال و إيجابى . ثانيا : لم تراعى قواعد المشاركة فى منتدى الأكسيل http://www.officena.net/ib/index.php?showtopic=60147 خمسة دقائق أخرى من وقتك الثمين و ستجد متعة فى التعامل بشكل صحيح و ميسر لك و لكافة الاعضاء ثالثا : جميع القواعد معلنة و بارزة و بمكان واضح و ليس مخفية أو سرية ستجعل منك عضوا متميزا فى أسلوبه و طرحه لمواضيعه سواء كانت سؤال او استفسار او شرح رابعا : أنت بكلامك قد أسئت للمنتدى بشكل صريح دون أن يكون هناك سبب لهذا التهجم و ذلك لأنك أهملت فى قراءة القواعد خامسا : أسئت لأحد المشرفين بشكل واضح و مباشر بالتعرض لإختصاصاته و مهامه الأساسية فهو القائم على تنفيذ قواعد المنتدى بشكل صارم و الا يعتبر مهملا كأى عضو عادى بالمنتدى لا يلتزم بالقواعد و لا يستحق منصبه القائم عليه سادسا : أسئت لغيرك من الأعضاء برغم من أن أحد لم يتأخر فى تقديم يد المساعدة و العون .. نحن هنا جميعا نساعد و نعاون دون أى مقابل الا مرضاة الله سبحانه و تعالى و نقتطع من أوقاتنا لمساعدة غيرنا على حلول مشاكلهم مع الأوفيس و غيره من البرامج أعضاء و مشرفين سابعا : لمجرد عدم حصولك على اجابة تصب جام غضبك على المنتدى برغم عراقته و كذلك كونه من أفضل المنتديات فى مجاله .. أنت لست أول و لا آخر واحد لا يجد لا لطلبه المسئلة قائمة على الفهم الصحيح للمشكلة حتى يتم حلها ( ليس سلق بيض أو قالب محفوظ ) و قائمة على تفهم قواعد الموقع و المنتدى و على إدراك صاحب المشكلة أنه قد أوصل مشكلته بشكل صحيح و مفهوم ثامنا : إن كنت ترى ان تأديه المشرف لمهامه استخفاف و إهانه فإن من واجبى كمسلم نصحك و إرشادك الى أنك مخطئ أخى الكريم من قمة رأسك لأخمص قدميك أرجو منك قراءة القواعد بعناية و قراءة كلامى بشكل صحيح حتى تعلم مكمن الخطأ و لا تظلم أحد فالظلم ظلمات يوم القيامة و بالنيابة عنك أعتذر لأخى الكريم ياسر خليل عما بدر من العضو الكريم من تعرض للمنتدى و له بشكل شخصى ارجو أن يتقبل أسفى و أعتذارى الشديد و لأخوتى الأفاضل 10 دقائق فقط يمكنها أن تجنبنا الخطأ و تقلل منه بشكل كبير بتفهمنا للقواعد تاسعا : الأخ الكريم أبو صاصا .. لم ترد على أى استفسار من الأعضاء و بدلا من ان ينصب همك على المشكلة انصب همك على شخصك و تحول الموضوع لمسئلة شخصية و ثأر وهميا فى مخيلتك .. فلا أنت تعرفنى بشكل شخصى او تعرف الأخ ياسر أو غيره و لا نحن نعرفك حتى نهينك او نستخف بمشاعرك على ما تظن و تعتقد عاشرا : نحن هنا جميعا فى خدمة بعضنا البعض دون مقابل الا مرضاة الله سبحانه و تعالى و كل شخص على قدر معرفته و علمه و كل منا يختفى وراء كلماته التى تفضح شخصيته الكلمة الطيبة يبقى أثرها فى النفوس و تذكر بخير و الكلمة الخبيثة يبقى اثرها و تذكر بشر مهما حاولنا و مهما اختفينا وراء الكلمات فهى تفضح مكنون النفوس فتخير كلماتك أخى الكريم و أحسن عرض أسلوبك لمسئلتك و انتقى من الخطوط ما يسر القلب و ما يريح العين ... ان كان كلامى خير فمن الله و فضله و ان كان كلامى شر فمن نفسى و أستغفر الله لى و لكم دمتم بخير جميعا و أعزكم الله

أخي الحبيب علاء بدلاً من استخدام جدول للنوع يمكن تعديل المعادلة لتؤدي الغرض بهذا الشكل بدون الاستعانة بجدول =VLOOKUP(A2,{"ذكر","ي";"أنثى","ت"},2,0)&IF(H2>=16,"وجه",IF(AND(G2>=10,H2<16),"نتقل","عيد السنة"))

تم تعديل الملف كي يعمل فقط على المعادلات اختر فقط من القائمة المنسدلة رقم السيارة و اكسل يقوم بالباقي اضغط اعجبني او افضل اجابة اذا كان كذلك المخالفات.zip

تفضل أخي الكريم اشرف التعديل الأخير Public Function Wish(RngData As Range, RngWish As Range, Start_WishColumn As Long, End_WishColumn, MarkColumn As Long, MinimumMark As Single) 'البارامتر الأول يمثل نطاق البيانات بالكامل 'البارامتر الثاني يمثل نطاق الرغبات والحد الأقصى المسموح به 'البارامتر الثالث يمثل رقم عمود بداية الرغبات ضمن النطاق 'البارامتر الرابع يمثل رقم عمود نهاية الرغبات ضمن النطاق 'البارامتر الخامس يمثل رقم عمود الدرجات ضمن النطاق 'البارامتر السادس يمثل الدرجة الصغرى والناتج يكون بدون توجيه '=Wish(D8:R27,U12:V23,3,14,15,10) '----------------------------------------------------------- Dim ArrData, ArrWish, ArrOut, ArrSwap Dim ColCount As Long, I As Long, J As Long, K As Long ArrData = RngData.Value ArrWish = RngWish.Value For I = 1 To UBound(ArrWish, 1) ArrWish(I, 2) = ArrWish(I, 2) Next I ReDim ArrOut(1 To UBound(ArrData, 1), 1 To 1) ColCount = UBound(ArrData, 2) ReDim ArrSwap(1 To 1, 1 To ColCount) For I = 1 To (UBound(ArrData, 1) - 1) For K = I To UBound(ArrData, 1) If ArrData(K, MarkColumn) > ArrData(I, MarkColumn) Then For J = 1 To ColCount ArrSwap(1, J) = ArrData(I, J) ArrData(I, J) = ArrData(K, J) ArrData(K, J) = ArrSwap(1, J) Next J End If Next K Next I For I = 1 To UBound(ArrData, 1) If ArrData(I, MarkColumn) < MinimumMark Then ArrOut(I, 1) = "بدون توجيه" Else For J = Start_WishColumn To End_WishColumn If ArrOut(I, 1) = "" Then For K = 1 To UBound(ArrWish, 1) If ArrData(I, J) = ArrWish(K, 1) Then If ArrWish(K, 2) > 0 Then ArrOut(I, 1) = ArrWish(K, 1) ArrWish(K, 2) = ArrWish(K, 2) - 1 End If End If Next K End If Next J End If Next I For I = 1 To (UBound(ArrData, 1) - 1) For K = I To UBound(ArrData, 1) If ArrData(K, 1) < ArrData(I, 1) Then ArrSwap(1, 1) = ArrData(I, 1): ArrSwap(1, 2) = ArrOut(I, 1) ArrData(I, 1) = ArrData(K, 1): ArrOut(I, 1) = ArrOut(K, 1) ArrData(K, 1) = ArrSwap(1, 1): ArrOut(K, 1) = ArrSwap(1, 2) End If Next K Next I Wish = ArrOut End Function

عموماً إليك الكود التالي عله يفي بالغرض إن شاء المولى Sub Test() Dim Coll As New Collection, ArrSheet, ArrTemp, ArrHolder, ArrOut1, ArrOut2 Dim I As Long, J As Long, P As Long, P1 As Long, P2 As Long, Str1 As String ArrSheet = Array(Sheets("مباع"), Sheets("مفعل"), Sheets("active"), Sheets("راجع")) ReDim ArrHolder(1 To Rows.Count, 1 To (UBound(ArrSheet) + 2)) ReDim ArrOut1(1 To Rows.Count, 1 To 1) ReDim ArrOut2(1 To Rows.Count, 1 To 1) For J = LBound(ArrSheet) To UBound(ArrSheet) ArrTemp = ArrSheet(J).Range("A2").CurrentRegion.Columns(1).Value On Error Resume Next For I = 1 To UBound(ArrTemp, 1) Str1 = CStr(ArrTemp(I, 1)) Coll.Add Key:=Str1, Item:=Coll.Count + 1 P = Coll(Str1) ArrHolder(P, 1) = ArrTemp(I, 1) ArrHolder(P, J + 2) = ArrHolder(P, J + 2) + 1 Next I On Error GoTo 0 Next J For I = 1 To Coll.Count P = 0 For J = 2 To UBound(ArrHolder, 2) P = P + Sgn(ArrHolder(I, J)) Next J If (P = UBound(ArrSheet) + 1) Then P1 = P1 + 1 ArrOut1(P1, 1) = ArrHolder(I, 1) Else P2 = P2 + 1 ArrOut2(P2, 1) = ArrHolder(I, 1) End If Next I With Sheets("النتيجة المطلوبة") .Range("A2").Resize(P1).Value = ArrOut1 .Range("B2").Resize(P2).Value = ArrOut2 End With End Sub سيتم استخراج الأرقام المتشابهة في كل أوراق العمل الأربعة معاً في العمود الأول أما الأرقام التي لم تحقق الشرط ستكون في العمود الثاني في ورقة العمل الأخيرة لا تنسى أن تحدد أفضل إجابة وأن تضغط على كلمة "أعجبني هذا" في حالة أن أعجبك الحل تقبل تحياتي Similar Data In Multi Sheets YasserKhalil.rar

أخي الكريم أشرف .. وهشام كمال الأخ الحبيب المتابع للموضوع من بدايته أخي وحبيبي علاء رسلان إليكم إصدار أفضل من الدالة المعرفة .. وبالمثال يمكنكم التعامل مع أي بيانات إن شاء الله Public Function Wish(RngData As Range, RngWish As Range, Start_WishColumn As Long, End_WishColumn, MarkColumn As Long) Dim ArrData, ArrWish, ArrOut, ArrSwap Dim ColCount As Long, I As Long, J As Long, K As Long ArrData = RngData.Value ArrWish = RngWish.Value For I = 1 To UBound(ArrWish, 1) ArrWish(I, 2) = ArrWish(I, 2) Next I ReDim ArrOut(1 To UBound(ArrData, 1), 1 To 1) ColCount = UBound(ArrData, 2) ReDim ArrSwap(1 To 1, 1 To ColCount) For I = 1 To (UBound(ArrData, 1) - 1) For K = I To UBound(ArrData, 1) If ArrData(K, MarkColumn) > ArrData(I, MarkColumn) Then For J = 1 To ColCount ArrSwap(1, J) = ArrData(I, J) ArrData(I, J) = ArrData(K, J) ArrData(K, J) = ArrSwap(1, J) Next J End If Next K Next I For I = 1 To UBound(ArrData, 1) For J = Start_WishColumn To End_WishColumn If ArrOut(I, 1) = "" Then For K = 1 To UBound(ArrWish, 1) If ArrData(I, J) = ArrWish(K, 1) Then If ArrWish(K, 2) > 0 Then ArrOut(I, 1) = ArrWish(K, 1) ArrWish(K, 2) = ArrWish(K, 2) - 1 End If End If Next K End If Next J Next I For I = 1 To (UBound(ArrData, 1) - 1) For K = I To UBound(ArrData, 1) If ArrData(K, 1) < ArrData(I, 1) Then ArrSwap(1, 1) = ArrData(I, 1): ArrSwap(1, 2) = ArrOut(I, 1) ArrData(I, 1) = ArrData(K, 1): ArrOut(I, 1) = ArrOut(K, 1) ArrData(K, 1) = ArrSwap(1, 1): ArrOut(K, 1) = ArrSwap(1, 2) End If Next K Next I Wish = ArrOut End Function يتم تحديد النطاق الذي تريد النتائج به S8:S27 ثم في شريط المعادلات ضع المعادلة التالية =Wish(D8:R27,U12:V23,3,14,15) ثم اضغط على Ctrl + Shift + Enter البارامترات الخاصة بالمعادلة : البارامتر الأول : نطاق البيانات بالكامل D8:R27 البارامتر الثاني : نطاق الرغبات والذي يحتوي على الرغبات والحد الأقصى المسموح به البارامتر الثالث: عمود بداية الرغبات وهو في المثال العمود رقم 3 والعد يبدأ من بداية نطاق البيانات .. أي أن العد في المثال يبدأ من العمود D البارامتر الرابع: عمود نهاية الرغبات وهو في المثال العمود رقم 14 وكما أخبرنا العد يبدأ من بداية نطاق البيانات البارامتر الخامس والأخير: هو رقم عمود المجموع وهو في المثال رقم 15 وكما أخبرنا ونؤكد أن العد من بداية نطاق البيانات لا تنسونا من صالح دعائكم Pupils Distribution According To Marks & Wishes V2.rar

الأخ الفاضل أبو إلياس إليك الكود بعد التصحيح .. من الأخطاء الظاهرة الخفية في الكود الذي قمت بكتابته كتابة رقم 1 بدلاً من حرف L في جملة xlup ويرجع ذلك إلى أنه عند كتابة حرف الـ L صغير بهذا الشكل l فإنه يشبه إلى حد كبير رقم 1 في محرر الأكواد .. وكذلك رقم 1 بدلاً من المتغير i يراعى عند كتابة الأكواد الدقة التااااااااامة ثم الدقة التامة .. التصحيح أصعب عندي من بناء الكود !! استغرق الأمر مني حوالي نصف ساعة لمعرفة الخطأ .. ظللت أنظر للكود ثم أنظر مرة أخرى ثم أنظر ولم ألاحظ أن حرف الـ L قد كتب بدلاً منه رقم 1 عموماً الحمد لله تم تدارك الخطأ .. ومعرفة مكمن المشكلة إليك الكود بعد التعديل Private Sub CommandButton1_Click() Dim MySH As Worksheet Dim I As Long, K As Long, R As Long, LR As Long Set MySH = Sheets("البيانات") K = 1 Columns("A:J").ClearContents For I = 3 To MySH.Cells(Rows.Count, 1).End(xlUp).Row LR = Cells(Rows.Count, 1).End(xlUp).Row + 1 For R = 1 To 10 If Me.Controls("CheckBox" & R) Then Cells(LR, K) = MySH.Cells(I, Me.Controls("CheckBox" & R).Caption) K = K + 1 End If Next R K = 1 Next I Unload Me End Sub لا تنسى أن تحدد أفضل إجابة .. كما لا تنسى أن تضغط على كلمة "أعجبني هذا" تقبل تحياتي :fff: Transfer Specific Columns By CheckBoxes On UserForm.rar

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

اصبر واسمعني لو سمحت: مرة واحد عربي تزوج زوجة جديدة على زوجته الاولى, وكانت الاولى لما تمر على الجديدة تقول: نقل فؤادك حيث شئت من الهوى...مالحب الا للحبيب الاولِ كم منزل في الارض يألفه الفتى...وحنينه ابدا لأول منزلِ فترد الثانية وتقول: وما يستوي الثوبان ثوب به البلى...وثوب بايدي البائعين جديدُ والخيار لك ياسيدي أن تبقى على زوجتك الاولى او الثانية. عفوا اقصد اوفسك الاول او اوفسك الثاني.. مملة الحكاية صح!!!!

انا اصوت للاستمرار على وضعك

الأخ الفاضل سلام الله عليكم شاهد المرفق وهو مشاركة سابقة لأحد الزملاء الأفاضل تحياتى *** جمال دغيدى ** منع فتح الملف إذا تم نقله أو تغيير إسمه ومنع حفظه بإسم جديد.rar