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

وعليكم السلام جرب الكود التالي حيث سيقوم الكود باستخراج القيم الفريدة أي الغير مكررة ويضعها في العمود الرابع Sub Test() Dim d As Object, rng As Range, c As Range Set d = CreateObject("Scripting.Dictionary") Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) For Each c In rng If c.Value <> "" Then d(Val(c.Value)) = Empty Next c Range("D1").Resize(d.Count) = Application.WorksheetFunction.Transpose(d.Keys) End Sub

وعليكم السلام ورحمه الله وبركاته تفضل اخي ياسر @yasse.w.2010 تعديل بسيط على كودك وتم اضافه شرط ان لم يكن يوجد صفحه بالاسم الذي تريد ان لا يعطى خطأ ويفتح الملف التالي Sub information() Dim wb As Workbook, WS As Worksheet, lr1 As Integer, lr2 As Integer Dim fil As Variant, dat As Long Dim sh As Worksheet Set sh = ThisWorkbook.Sheets("Temp") Application.ScreenUpdating = False ''' غلق اهتزاز الشاشه Application.DisplayAlerts = False ''' غلق اي رساله تظهر مثل الحفظ الخ lr1 = sh.Cells(Rows.Count, 1).End(xlUp).Row ''' ار صف فيه بيانات في العامود الاول sh.Range("A10:k" & lr1 + 1).ClearContents '''مسح البيانات في هذا النطاق INF = ThisWorkbook.Path '''مسار الملف fil = Dir(INF & "\*.xl??") ''' مسار الملف في اي مكان Do While fil <> "" ''' المرور على كل الملفات If fil <> "DATA.xlsm" Then ''' اسم الملف الذي لا يتم جلب البيانات منه Set wb = Workbooks.Open(INF & "\" & fil) ''' فتح الملففات من المسار lr1 = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1 ''' تحديد مكان نسخ الخلايا If Not IsError(Evaluate("ISREF('[" & wb.Name & "]" & "reservation" & "'!A1)")) Then Set WS = wb.Worksheets("reservation") lr2 = WS.Cells(Rows.Count, 2).End(xlUp).Row ''' تحديد عامود اخر خليه بها بيانات ليتم نسخها WS.Range("A8:k" & lr2).Copy '''نسخ البيانات من الملف الى ملف اخر sh.Range("a" & lr1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False dep = Left(wb.Name, Application.Search(".", wb.Name) - 1) ''' تحديد اسم اسم الملف و الغاء الامتداد الخاص بالملف sh.Range("h" & lr1 & ":h" & lr1 + lr2 - 8) = dep ''' مكان اسم الملف End If wb.Close ''' غلق الملف End If fil = Dir ''' تكرار الملفات Loop Application.DisplayAlerts = True ''' فتج اهتزاز الشاشه Application.ScreenUpdating = True ''' فنح رسائل الحفظ End Sub

السلام عليكم ورحمة الله وبركاته النسخة تجريبية وبدون أكواد برامج المواقيت كثيرة وأكثر احترافية وفي كل جوال ولكن بين فترة وأخرى أحب أن أتحدى الأكسل وفي كل مرة يكسب التحدي ويبدى امكانياته الهائلة مواقيت الصلاة.xlsb

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

قم بحذف جميع السطور من بدايه السطر ١٠ الي نهايه الشيت لان بها خلايا مدمجه مثل الصورة

انظر هنا ما تفكر به نفسه

تم تعديل المعادلات مقتبسة من أستاذنا الفاضل / ياسر خليل أبو البراء خبير أوفسينا OK OK للرفع.xlsx

وعليكم السلام ورحمة الله وبركاته هذا اجتهاد مني في العمود B ايضاح المكرر وفي العود C حذف المكرر مثال-أوفيسنا.xlsx

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

استخدام System.Collections.ArrayList يلزم أن يكون مسطب لديك النت فريم ورك 3.5 إذا قمت بتسطيب النت فريم ورك واستمرت المشكلة ، قم بإرفاق الملف الذي به المشكلة للإطلاع عليه

بسم الله الرحمن الرحيم استخراج القيم الفريده بطريقة العلامه عبد الله باقشير .. حفظه الله ورعاه مع شرح الكود جزى الله كل من ساهم في اخراج هذا العمل الى النور بكل خير Private Sub Worksheet_Activate() 'هذاالكود خاص بالعلامه عبد الله باقشير 'حفظه الله ' الهدف من الكود هو الاتيان بالقيم الفريده 'تم هذا الكود في 23/06/2007 '' '' '' '' '' '' '' '''' '' '' '' '' '' '' '' Application.ScreenUpdating = False 'مسح عمود القيم الفريده [V5:V500].ClearContents 'متغير عمود القيم الفريده Set MyRange = [V5:V500] 'اسم شيت المصدرورقم صف البدايه في شيت المصدر For U = 7 To Sheets("رصد الترم الثانى").[C1500].End(xlUp).Row 'رقم عمودالبيانات الفريده ورقم عمود بيانات المصدر Cells(U, 22) = Sheets("رصد الترم الثانى").Cells(U, 4) 'رقم عمودالبيانات الفريدهفي الشيت الهدف If Application.WorksheetFunction.CountIf(MyRange, Cells(U, 22)) > 1 Then 'رقم عمودالبيانات الفريده Cells(U, 22).ClearContents End If Next 'فرز عمود القيم الفريده [V5:V500].Sort [V5], xlAscending Application.ScreenUpdating = True End Sub استخراج القيم الفريده.rar

تفضل اخي الكريم جرب الان هذا التعديل الكنترول المدرسى.mdb

لوبحثت قليلا في الموقع لوجدت الحل يوجد لديك خطأ في احد الاكواد .. ويلزم التصحيح من محرر الفيجوال : Tools / References

تفضل أخي الكريم أرجو أن يكون الحل: Retails Sales Report (2).xlsx

جريب هذا الكود Sub FasterMacro() Dim wsSource As Worksheet Dim wsCriteria As Worksheet Dim wsExtract As Worksheet Dim sourceRange As Range Dim criteriaRange As Range Dim extractRange As Range ' تحديد ورقة المصدر Set wsSource = ThisWorkbook.Sheets("Sheet1") ' قم بتغيير "Sheet1" إلى اسم ورقتك ' تحديد ورقة المعايير Set wsCriteria = ThisWorkbook.Sheets("ÇáÊÓÌíá (2)") ' قم بتغيير اسم الورقة إذا لزم الأمر ' تحديد ورقة الاستخراج Set wsExtract = ThisWorkbook.Sheets("ÇáÊÓÌíá (2)") ' قم بتغيير اسم الورقة إذا لزم الأمر ' تحديد نطاق البيانات المصدر Set sourceRange = wsSource.Range("AM:BD") ' تحديد نطاق المعايير Set criteriaRange = wsCriteria.Range("'Criteria'") ' تحديد نطاق الاستخراج Set extractRange = wsExtract.Range("'Extract'") ' تطبيق تصفية متقدمة sourceRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=criteriaRange, CopyToRange:=extractRange, Unique:=False ' تحديد نطاق آخر (يمكن تعديله وفقًا لاحتياجاتك) wsSource.Range("DC3:DT3").Select End Sub

وانزلتها الى صيغة اكسس 2000 🙂 color2.zip

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

جرب الآن طبعا بالتلوين يمكن عمل التالي: - تكرار للبحث عن الكلمة المراد تلوينها في السجل الواحد. - تكرار للبحث عن الكلمة في جميع السجلات. SearchSel_02.accdb

إن شاء الله يفيدك هذا التعديل تم وضع معادلا للجمع وشروط لاختبار الاجمالي مع المساحة ملف فارغ لحساب - حصر المزروعات - للرفع.xls

فورم حساب الورث للمتوفى بالاكسل الفيديو الصور رابط الملف http://www.mediafire.com/file/7ryeba73vp71sni/حساب+الميراث.rar

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

تفضل جمع مساحات .rar

استاذ ياسر خليل السلام عليكم ورحمة الله وبركاته جزاك الله خيرا وبارك فيك .. آمين يارب العالمين وبعد : Sub القيم_الفريده() 'هذا الكود تم بواسطه المحترم ياسر خليل 'الهدف من الكود 'الاتيان بالقيم الفريده لبيانات في عمود 'تم في 31/8/2017 Dim rng As Range Dim a As Variant Dim ws As Worksheet 'اسم الخليه في صفحه الهدف ' التي ستظهر بها القيم القريده Const strTRng As String = "D4" 'في صفحه الهدف العمود المطلوب ' وضع القيم الفريده فيه Const strHRng As String = "D4:D1000" 'في صفحه المصدر العمود المطلوب ' استخراج القيم الفريده منه Const strSRng As String = "C10:C200" 'اسم الشيت في صفحه المصدر Const str As String = "Sheet1" Set ws = Sheets(str) '====================== 'نفترض وجود بيانات كأسماء في النطاق المذكور Set rng = ws.Range(strSRng) ActiveSheet.Range(strHRng).ClearContents 'تخزين النتائج في مصفوفة a = GetDistinct(rng) 'النطاق المطلوب وضع النتائج للأسماء الغير مكررة فيه ActiveSheet.Range(strTRng).Resize(UBound(a, 1) + 1) = Application.Transpose(a) 'فرز العمود المنقول اليه القيم الفريده [D4:D200].Sort [D4], xlAscending 'عمود القيم الفريده ستتم عليه بعض التنسيقات With ActiveSheet.Range(strHRng) 'تنسيق العمود تكست .EntireColumn.NumberFormat = "@" .Font.Bold = True .ReadingOrder = xlRTL: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter End With End Sub Function GetDistinct(ByVal oTarget As Range) As Variant Dim dic As Object Dim vArr As Variant Dim v As Variant Set dic = CreateObject("Scripting.Dictionary") vArr = oTarget For Each v In vArr If Not IsEmpty(v) Then dic(v) = v Next v GetDistinct = dic.Items() End Function ================ منقول للافاده

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

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

مشكور اخي الغالي ياسر علي مجهودك واعادة شرحك للموضوع ولاثراء الموضوع تفضل هذا مثال كنت قد وضعته منذ فترة في المنتدى لعله ينفع احدكم http://www.officena.net/ib/topic/64199-تصفح-الانترنت-من-داخل-برنامجك-على-الاكسيل/ ولكم كل الشكر والتقدير

سابعا تسمية command Button الأول Search والثانى Back و كتابة إسم موقع فى الخلية D2 كما بالصورة الأتية ثامنا /الضغط دبل كليك على command Button وكتابة الكود الأتى Private Sub CommandButton1_Click() link_name = Sheets("sheet1").Range("d2") Call Sheets("sheet1").WebBrowser1.Navigate(link_name) End Sub أرجوا أن أكون وفقت فى الشرح معلشى بقى أخى الحبيب / ياسر خليل شرحى على قدى

بناء على طلب الأخ الحبيب أستاذى الفاضل / ياسر خليل بشرح الخطوات مكتوبة الخطوات كالتالى أولا : فتح شيت إكسيل جديد ثانيا : تحويل الشيت إلى إمتداد XLSM كما بالصورة الأتية : ثم الضغط على Save ثالثا : ندخل على شاشة Developer وإن كانت غير موجودة يتم إظهارها كما بالصورة الأتية : ندخل على File ثم على Options ثم على Customize Ribbon ثم نعلم على علامة صح التى بجوار Developer كما بالصورة الأتية : رابعا : فى شاشة Developer ندخل على Insert ثم على More Controls كما موضح بالصورة الأتية : خامسا : نختار من الإختيارت التى ستظهر Microsoft Web Browser كما بالصورة الأتية ونقوم بتحديد مكانة داخل صفحة الإكسيل سادسا : فى شاشة Developer ندخل على Insert ثم على command Button مرتين بجوار بعض كما بالفيديو والطريقة كما موضح بالصورة الأتية : تابع