ابو تراب

جزاك الله خيرا على هذه الاجراء المختصر فعلا. تجدر الملاحظة ان الاجراء RemoveDuplicates يزيل الاسطر المكررة بدون حذفها على العموم كتبت اجراء جديد مستفيدا من ماتفضلت به بحيث يصبح عام قدر الامكان بدون التقيد بابعاد الجدول لا ادري اذا كان من الافضل اضافة هذا الاجراء الى المكتبة او الحفاظ على بساطة الفكرة ووضوحها .. اترك القرار لك. تقبل شكري و تقديري مرفق مثال للتجريب Public Sub RemoveDuplicates(StartCell As Range, Optional Header As Boolean = False) Dim Table As Range Dim TotalCols As Long Dim ColArray As Variant Dim Col As Long If StartCell.Count > 1 Then Exit Sub Set Table = StartCell.CurrentRegion TotalCols = Table.Columns.Count ReDim ColArray(0 To TotalCols - 1) For Col = 1 To TotalCols ColArray(Col - 1) = Col Next Application.ScreenUpdating = False If Header Then Table.RemoveDuplicates Columns:=(ColArray), Header:=xlYes Else Table.RemoveDuplicates Columns:=(ColArray), Header:=xlNo End If Application.ScreenUpdating = True End Sub Remove Duplicates اجراء عام لازالة الاسطر المكررة.zip

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

هلا و غلا باخي و استاذنا ياسر ...شكر الله لك كلماتك الطيبة ولا يهمك اي فكرة او معلومة ان شاء الله نشارك بها في المنتدى الغالي .Mr. Haridy لسة ما تعرفنا عليه

كود لحذف الاسطر المكررة شرح مختصر للكود الفكرة هى فحص السطر كاملا (و ليس خلية بخلية) عن طريق الدالة Join بما ان الدالة Join تقبل مصفوفة ذات بعد واحد و في نفس الوقت فان الكائن range يعيد مصفوفة دات بعدين البعد الاول هو من 1 الى 1 و البعد الثاني هو من 1 الى عدد الاعمدة في المدى هنا لتمرير بعد واحد فقط يمكننا استخدام الدالة Transpose. فللاعمدة يمكننا تمرير الدالة Transpose مرة و احدة بينما للاسطر فنحتاج لتمريرها مرتين Sub btnRemoveDuplicates() Const FirstRow As Long = 1 Dim LastRow As Long Dim LastColChr As String Dim Addr1 As String Dim Addr2 As String Dim i As Long Dim j As Long ' احصل على رقم الصف الاخير للجدول LastRow = Range("A" & Rows.Count).End(xlUp).Row ' استخلص اسم العمود الاخير للجدول LastColChr = Cells(1, Columns.Count).End(xlToLeft).Address LastColChr = Replace(Replace(LastColChr, "$", ""), "1", "") If Range("A1:" & LastColChr & LastRow).Rows.Count > 2 ^ 16 Then Exit Sub With Application For i = FirstRow To LastRow - 1 ' حدث عنوان السطر الحالي Addr1 = "A" & i & ":" & LastColChr & i ' حدث عنوان السطر التالي For j = i + 1 To LastRow Addr2 = "A" & j & ":" & LastColChr & j ' افحص تطابق السطرين If Join(.Transpose(.Transpose(ActiveSheet.Range(Addr1).Value)), Chr(0)) = _ Join(.Transpose(.Transpose(ActiveSheet.Range(Addr2).Value)), Chr(0)) Then ' احذف السطر و عد حسابات ابعاد الجدول Range(Addr2).Delete xlShiftUp j = j - 1 LastRow = Range("A" & Rows.Count).End(xlUp).Row End If Next j Next i End With End Sub Remove Duplicates حذف الاسطر المكررة.zip

يامرحبا باخي و استاذي الغالي الصقر شكرا الله لك كلماتك الطيبة و مرورك العطر

كود لاستخلاص حرف/حروف او اسم العمود من عنوان الخلية مثال مرفق للتوضيح Public Function GetColumnLetter(Cell As Range) As String Const NOT_SINGLE_CELL As Long = vbObjectError + 1001 Dim ColLetter As String ' تأكد ان المدى يمثل خلية واحدة فقط If Cell.Count > 1 Then GetColumnLetter = CVErr(NOT_SINGLE_CELL): Exit Function ' استخلص اسم العمود من عنوان الخلية ColLetter = Cells(1, Cell.Column).Address ColLetter = Replace(Replace(ColLetter, "$", ""), "1", "") GetColumnLetter = ColLetter End Function استخلص اسم العمود Get Column letter char.zip

اهلا و سهلا استاذ ساهر .. شرفنا مرورك العطر بالمناسبة تذكرت سؤالك عن حساب ايام العمل، الدالة الصحيحة هى Networkdays.INTL في الصورة ادناه اعطيت لك مثال بحساب ايام العمل بدون خصم الاجازات او مع خصمها

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

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

جزاك الله خيرا استاذ ابن مصر قد يكون السبب اختلاف الاوفس

جزاك الله خيرا على التنبية الملف بعد التعديل 2فلترة متقدمة.zip

ما شاء الله تبارك الله .. تمكنك من المعادللات متميز فعلا جزاك الله خيرا استاذ محمد على المعادلة الاكثر من رائعة فقد استخدمتها في الملف المرفق كما يلي: =IFERROR(INDEX('بيانات الطلبة'!$V$7:$V$212,MATCH(0,COUNTIF($S$9:$S9,'بيانات الطلبة'!$V$7:$V$212),0)),"") استاذ قصي معادلة الاستاذ محمد تفي بالغرض و تتجاوز تعقيد كتابة الكود..اذا اردت بالكود فيمكن عمل ذلك عن طريق فك الحماية و من ثم اعادتها اترك لك الملف بالمعادلات للتجريب فلترة متقدمة.zip

اخي هذه محاولة جرب المرفق حذف خلية من الكمبو بكس.zip

يا اهلا وسهلا بالاستاذ قصي

هلا بالاستاذ قصي تفضل الملف بعد التعديل فلترة متقدمة.zip

الاستاذ الفاضل قصي يفترض الان ان تعمل تفضل عاين المرفق Advance Filter فلترة.zip

الاستاذ قصي تفضل Advance Filter فلترة.zip

بالاضافة ما تفضل به استاذنا الفاضل طارق محمود من شرح رائع بالفديو يمكن ايضا عملها اي Advance Filter بالكود كما في الملف المرفق Sub btnUniqueValues() Sheet1.Range("T5:T78").AdvancedFilter Action:=xlFilterCopy, copytorange:=Sheet3.Range("P1"), unique:=True Sheet3.Activate End Sub Advance Filter فلترة.zip

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

تعديل في الكود

وعليكم السلام و رحمة الله و بركاته جرب الحل في الرابط التالي: http://www.officena.net/ib/index.php?showtopic=57502

اهلا و سهلا بالاستاذ محمد الريفي .. شرفنا مرورك العطر... تقبل تقدير و شكري لكلماتك الطيبة

كود لنسخ ملف الاكسل كل 30 يوما و يتم تخزين الملف الجديد في المجلد Monthly Reports مع تاريخ الانشاء و اللوقت عملت مثال لتتضح الطريقة كل ماعليك فعله هو وضع الاجراء CheckAndCopyThisWB في حدث فتح الملف Sub CheckAndCopyThisWB() ' المجلد الذي سيتم تخزين الملفات فيه Const DestDir As String = "\Monthly Reports\" ' عنوان الخلية التي تحتوي على اخر تاريخ تم نسخ الملف Const LastCopyCell As String = "B1" ' اسم الملف بدون امتداد Dim WBName As String ' امتداد الملف بدون الاسم Dim WBExtension As String ' المسار كاملا لملف المصدر Dim SourceFile As String ' المسار كاملا للملف الجديد Dim DestFile As String ' تأكد انه مرة 30 يوما على اخر عملية نسخ او ان الملف ينسخ للمرة الاولى If Sheets("LOG").Range(LastCopyCell).Value = "" Or DateAdd("d", 1, Sheets("LOG").Range(LastCopyCell).Value) <= Date Then WBName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - (Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, ".") + 1)) WBExtension = Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, "."), 7) SourceFile = """" & ThisWorkbook.FullName & """" DestFile = """" & ThisWorkbook.Path & DestDir & WBName & Format(Now(), "dd-mmm-yy-h-mm;@") & WBExtension & """" ' انسخ الملف Shell "CMD /C COPY /-Y " & SourceFile & " " & DestFile, vbHide ' حدث تاريخ اخر عملية نسخ Sheets("LOG").Range(LastCopyCell).Value = Date End If End Sub Check and Copy Workbook.zip

تفضل ارجوا التاكد من صحة الفروقات....الدالة مازالت في طور التطوير تعديل الكود بدل خلية عمود.zip

تم الاختيار بناء على اكواد الدالة الخاصة بعطل نهاية الاسبوع Weekend اما الاجازات Holydays فأنت من يحددها و لهذا افترضت ان 5 يناير هو يوم اجازة كمثال فقط انظر للصورة ادناه