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

الاخوة الكرام فى هذا الصرح العظيم فكرة بسيطه خطرة فى بالى عن كيفية استغلال RefEdit فى الترحيل كما يمكن تطويرها ايضا فيما بعد مرفق ملف للتجربه تقبلوا تحياتى الترحيل بواسطة RefEdit1.zip

تفضل جرب المرفق Export Workbooks Using Filter Method V2.rar

السلام عليكم و رحمة الله وبركاته سوف يقوم الكود بالتالي حيث ان الورقة التي ينقل اليها البيانات هي ليست ورقة عمل لذلك يتم ادراج ورقة عمل جديدة ونقل البيانات اليها توزيع البيانات على الأعمدة تصحيح صيغة التاريخ من mm/dd/yyyy الى dd/mm/yyyy فرز البيانات وترتيبها تنازليا Sub Reset_New_Data() ' تحديث بيانات تم جلبها من ملف خارجي Dim FS As Worksheet, TS As Worksheet, RN1 As Range Dim ER Set FS = Sheets(ActiveSheet.Name) Sheets.Add Set TS = Sheets(ActiveSheet.Name) FS.UsedRange.Copy TS.Range("A2").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False 'Set RN1 = TS.UsedRange ER = TS.UsedRange.Rows.Count + 3 Set RN1 = TS.Range("A1:A" & ER) ' Range("B1:K1").EntireColumn.Insert RN1.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _ Semicolon:=False, Comma:=True, Space:=False, Other:=False, OtherChar _ :="/", FieldInfo:=Array(Array(1, 4), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _ 1), Array(6, 1), Array(7, 1)), TrailingMinusNumbers:=True ' Range("B1:D1").EntireColumn.Insert RN1.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _ Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _ :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _ TrailingMinusNumbers:=True Range("D1:D" & ER).FormulaR1C1 = "=DATE(RC3,RC1,RC2)" Range("D1:D" & ER).Copy Range("D1:D" & ER).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Columns("A:C").Delete Shift:=xlToLeft Range("A1:O1").ClearContents ActiveSheet.UsedRange.Select Selection.Sort Key1:=Range("A2"), Order1:=xlDescending, Header:=xlYes, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Selection.Font.Size = 13 Selection.Columns.AutoFit Range("A1").Select End Sub طريقة الإستخدام تقوم بفتح الملف الذي تم الجلب البيانات اليه (الملف الجديد) تفتح هذا الملف تضغط بزر الماوس الأيمن على زر تحديث الموجود في هذا الملف تختار نسخ تذهب الى الملف الجديد - الورقة التي بها البيانات التي تم جلبها تضغط بزر الماوس الأيمن على أي مكان في الورقة التي بها البيات تختار لصق يتم ادراج الزر في الورقة اضغط على الزر بزر الماوس الأيسر يتم عمل المطلوب توزيع البيانات و فرزها.rar

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

أفضل إجابة نحن نصنعها إذاً

هذا كود آخر جربه يمكن يتعامل معاك مع الهمزة على نبرة Sub ReplaceChars() Dim ToRemove(), Itm Dim Cel As Range ToRemove() = Array("أ", "إ", "آ") For Each Itm In ToRemove() For Each Cel In Range("F16:F" & Cells(Rows.Count, "F").End(xlUp).Row) Cel.Replace What:=Itm, Replacement:="ا", MatchCase:=True Next Cel Next Itm End Sub يبدو من مشاركتك الأخيرة انك تريد استبدال الحرف الأول فقط عموماً جرب الكود ولن تخسر شيئاً

Sub SortSheets() Dim I As Integer, J As Integer For I = 1 To Sheets.Count - 1 For J = I + 1 To Sheets.Count If Val(Sheets(I).Name) > Val(Sheets(J).Name) Then Sheets(J).Move Before:=Sheets(I) End If Next J Next I End Sub

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

أخي الكريم أبو عبد الملك مشكور على كلماتك الرقيقة إليك الكود التالي عله يفي بالغرض Sub FollowAll() Dim I As Long, lRow As Long Dim rngFound As Range Dim wsRecord As Worksheet, wsMonthly As Worksheet, SH As Worksheet Set wsRecord = Sheets("معلومات التسجيل"): Set wsMonthly = Sheets("مجمع النتائج الشهرية"): Set SH = Sheets("كشف متابعة") With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual End With With wsRecord For I = 2 To .Cells(Rows.Count, "A").End(xlUp).Row If Not IsEmpty(.Cells(I, "N")) Then If MsgBox("الطالب " & .Cells(I, "C") & " منقطع هل تود أن تطبع له كشف?", vbYesNo + vbMsgBoxRtlReading) = vbYes Then GoTo Continue Else: End If Else Continue: SH.Range("C1") = .Cells(I, "C") SH.Range("C4") = .Cells(I, "B") SH.Range("C5") = .Cells(I, "A") Set rngFound = wsMonthly.Columns("C:C").Find(What:=.Cells(I, "C"), searchorder:=xlByRows, searchdirection:=xlPrevious) If Not rngFound Is Nothing Then lRow = rngFound.Row If wsMonthly.Cells(lRow, "R") >= 60 Then SH.Range("R4") = wsMonthly.Cells(lRow, "N"): SH.Range("S4") = wsMonthly.Cells(lRow, "O") ElseIf wsMonthly.Cells(lRow, "R") < 60 Then SH.Range("R4") = wsMonthly.Cells(lRow, "L"): SH.Range("S4") = wsMonthly.Cells(lRow, "M") Else MsgBox "لا يوجد درجة للطالب " & .Cells(I, "C"), vbCritical End If End If SH.Range("C2").Formula = "=IF(" & SH.Range("R4").Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & SH.Range("R4").Address & ",QNames,0)),الحلقات!$F$2:$F$6,الحلقات!$B$2:$B$6))" SH.Range("C3").Formula = "=IF(" & SH.Range("R4").Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & SH.Range("R4").Address & ",QNames,0)),الحلقات!$F$2:$F$6,الحلقات!$D$2:$D$6))" SH.Range("C2:C3").Value = SH.Range("C2:C3").Value Call CalculateLinesOfRevision SH.PrintPreview End If Next I End With With Application .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic End With End Sub Private Sub CalculateLinesOfRevision() Dim SH As Worksheet, wsMnhg As Worksheet Dim LRCur As Long, I As Long, N As Long, Counter As Long Dim rngA As Range, rngB As Range, rngC As Range, rngD As Range Dim X, Y Set SH = Sheets("كشف متابعة"): Set wsMnhg = Sheets("المنهج") With wsMnhg LRCur = .Cells(Rows.Count, 1).End(xlUp).Row Set rngA = .Range("A2:A" & LRCur): Set rngB = .Range("B2:B" & LRCur) Set rngC = .Range("C2:C" & LRCur): Set rngD = .Range("D2:D" & LRCur) SH.Range("Q11:Q34").ClearContents X = ValueLookUp(rngB, SH.Cells(4, "R").Value, rngC, rngD, SH.Cells(4, "S").Value, rngA) If X <= 24 Then For I = 2 To X + 1 SH.Cells(N + 11, "Q") = .Cells(I, "B") & " " & .Cells(I, "C") & " - " & .Cells(I, "B") & " " & .Cells(I, "D") N = N + 1 Next I Else Y = Application.WorksheetFunction.Ceiling(X / 24, 1) For I = 2 To X + 1 Step Y SH.Cells(N + 11, "Q") = .Cells(I, "B") & " " & .Cells(I, "C") & " - " & .Cells(I + Y - 1, "B") & " " & .Cells(I + Y - 1, "D") N = N + 1 Counter = Counter + Y If Y >= X - I Then Exit For Next I If X - Counter > 0 Then SH.Cells(N + 11, "Q") = .Cells(I + Y, "B") & " " & .Cells(I + Y, "C") & " - " & .Cells(X + 1, "B") & " " & .Cells(X + 1, "D") End If End With End Sub

جرب تعدل السطر التالي Found = Application.Match(.Cells(I, "F"), .Range("A4:A" & LR), 0)

أخي الكريم اشرف جرب الكود التالي عله يفي بالغرض Sub TransferWithCriteria() Dim Source As Worksheet, Target As Worksheet Dim LR As Long, I As Long, X As Long Dim SourceRange As Range, Found Set Source = Sheet1: Set Target = Sheet2 LR = Source.Cells(Rows.Count, 1).End(3).Row X = 8 Application.ScreenUpdating = False Target.Range("D8:T1000").ClearContents With Source For I = 4 To LR Found = Application.Match(.Cells(I, "G"), .Range("B4:B" & LR), 0) If IsNumeric(Found) Then If .Cells(Found + 3, 3) >= 50 And .Cells(Found + 3, 4) >= 2 And .Cells(Found + 3, 5) >= 14 Then .Cells(Found + 3, 1).Resize(1, 2).Copy Target.Cells(X, "D").PasteSpecial xlPasteValues .Cells(Found + 3, 3).Resize(1, 3).Copy Target.Cells(X, "R").PasteSpecial xlPasteValues Target.Cells(X, "F").Resize(1, 5).Value = .Cells(I, "H").Resize(1, 5).Value X = X + 1 End If End If Next I End With Source.Activate Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Done.", 64 End Sub Transfer Based On Specific Criteria YasserKhalil.rar

اريد عند الضغط على زر الترحيل تظهر لنا يوزر فورم تحتوي على كمبوبوكس يتم من خلاله اختيار التوجيه النهائي و بعد اختيار توجيه نضغط على زر ترحيل الموجود اليوزر فورم فيقوم بترحيل قائمة هذا التوجيه الى sheet 1 " متضمن رقم القيد و اسم الطالب فقط" اكتر توضيح في الملف المرفق Export Workbooks Using Filter Method V1.rar

السلام عليكم وهذه محاولة مني :-) http://www.officena.net/ib/topic/63113-نسخ-ملف-خارجي-في-مجلد-خارجي/ جعفر

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

أشكرك جدااااااااااااااااااااااااااااااااااااااااااااااااااااااااا مشكلتي قد حُلّت

السلام عليكم ورحمة الله وبركاته سنتابع اليوم ما بدأنا به في نموذج تعريف المادة وهذه المرحلة هي الاصعب وهي عملية البحث واضافة البيانات الى التصنيف قمنا بالخطوات التالية : 1- إضافة نماذج على شكل ورقة بيانات لكل جدول من جداول التصنيف بالاسماء التالية frmgrp1-frmgrp2- frmgrp3-frmgrp4 2- تم اضافة نموذج البحث frmfinder فهو سيقوم بالبحث واضافة البيانات الى نموذج تعريف مادة 3- قمت بإنشاء متغيرات عمومية ضمن الوحدة النمطية module1 Public fgrb As String, findcode As Integer, findnamee As String, typegrb As Integer الاول لحفظ نص البحث المطلوب ونقله من نموذج تعريف المادة الى نموذج البحث وهو ايضا معيار البحث في نموذج finder الثاني متغير لحفظ رقم الكود فيه ونقله من نموذج البحث الى نموذج تعريف المادة الثالث متغير لحفظ الاسم فيه ونقله من نموذج البحث الى نموذج تعريف المادة الرابع متغير يحفظ أرقام لتحديد النموذج الفرعي داخل نموذج البحث frmfinder وسيتم استخدامه في حدث عند التحميل في نموذج البحث بحيث عندما البحث في المجموعة الاولى سيكون النموذج الفرعي هو النموذج الفرعي الخاص بالمجموعة الاولى frmgrp1 وعندما نريد البحث في المجموعة الثانية يكون النموذج الفرعي هو frmgrp2 وهكذا ... الان ننتقل الى نموذج تعريف مادة نبدأ بالبحث في المجموعة الاولى في التصنيف (اللون) نكتب النص الذي سنبحث عنه ثم نضغط انتر لاحظ الكود في حدث بعد التحديث On Error Resume Next If IsNull(Me.namegrp1) = False Then typegrb = 1 fgrb = Me.namegrp1 DoCmd.OpenForm "frmfinder", , , , , acDialog Me.namegrp1 = findnamee Me.codegrp1 = findcode End If نبدأ بالتأكد من أن الحقل ليس فارغا ثم نعطي متغير تحديد النموذج الفرعي القيمة 1 ثم نعطي المتغير fgrb قيمة نص البحث ثم نقوم بفتح نموذج البحث frmfinder بوضع مربع حوار هنا سيظهر نموذج البحث ويعطينا النتيجة نختار اللون الذي نريده ونضغط موافق يقوم زر موافق بحفظ نتيجة البحث في المتغيرات المخصصة لها وذكرتها سابقا في بداية الشرح ويقوم باغلاق نموذج البحث (يمكنك مراجعة زر موافق في نموذج البحث ) سؤال يطرح نفسه لماذا اخترنا فتح نموذج البحث على شكل مربع حوار ؟ الجواب :حتى يتوقف تنفيذ الكود حتى نحصل على النتيجة بعد إغلاق نموذج البحث ثم بكل بساطة نقوم بإضافة النتيجة الى نموذج تعريف المادة باستخدام المتغييرات ننتقل إلى نموذج البحث frmfinder 1- كما ذكرت سابقا فيه نموذج فرعي يتغير مصدره من حدث عند التحميل استنادا للمتغير الخاص به وهو typegrb 2- في الوحدة النمطية module1 تم اسناد قيمة المتغير fgrb الى دالة وذلك بوضعه ضمن function Function findgrb() findgrb = fgrb End Functiongrb وقمت باستخدام هذه الدالة findgrb كقيمة افتراضية في مربع النص search ضمن نموذج البحث وأيضا كعامل تصفية في نماذج التصنيف 3 - ستجد زر جديد في النموذج سيقوم هذا الزر بفتح مجال لاضافة بيانات ضمن النموذج الفرعي مباشرة وذلك بالسماح بالاضافة للنموذج الفرعي Me.grbs.Form.AllowAdditions = True أخيرا في نموذج خيارات تم تفعيل عملية النسخ الاحتياطي واستعادة نسخة احتياطية بكود نسخ ولصق اعتمادا على البيانات الموجودة في النموذج accurate 16.rar

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

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

الحمد لله .. ولك بمثل ما دعوت وفقك الله لكل خير

السّلام عليكم و رحمة الله و بركاته استاذي الغالي ياسر خليل أبو البراء .. أنا أستعمل في تفعيل جميع نسخ الأوفيس و حتى الويندوز 8 أستعمل KMS PICO 9.0.5.20131112 ..ما عدا الأوفيس 2010 أستعمل OFFICE 2010 TOOLKIT ACTIVATOR .. والحمد لله لم أجد أدنى مشكل في تفعيل جميع هذه النسخ ..و بدون قطع النت.. جرّب رفع الأداتيْن أستاذنا العزيز ..إليك الرابط : http://www.up-00.com/?ldBh

لا تستعمل Application.InputBox افضل استعمال vba.InputBox Private Sub CommandButton1_Click() Unload Me End Sub Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then Dim rng As Range, LR As Long Dim x x = InputBox("Please enter a Quntity") If x = False Or StrPtr(x) = 0 Or Not IsNumeric(x) Then Exit Sub Else LR = Sheets("invoice").Cells(Rows.Count, "E").End(xlUp).Row + 1 Set rng = Sheets("invoice").Cells(LR, 4) If ListBox1.Value <> "" Then rng.Value = ListBox1.Value rng.Offset(0, 1).Value = ListBox1.List(ListBox1.ListIndex, 1) rng.Offset(0, 4).Value = ListBox1.List(ListBox1.ListIndex, 2) rng.Offset(0, 2).Value = x End If End If End If End Sub Private Sub TextBox1_Change() Dim LR As Integer, R As Integer, T As Integer ListBox1.Clear With Sheets("Codes") LR = .Cells(.Rows.Count, 2).End(xlUp).Row For R = 2 To LR If .Cells(R, 2) Like "*" & TextBox1.Text & "*" Then ListBox1.AddItem ListBox1.List(T, 0) = .Cells(R, 1) ListBox1.List(T, 1) = .Cells(R, 2) ListBox1.List(T, 2) = .Cells(R, 4) ListBox1.List(T, 3) = .Cells(R, 5) T = T + 1 End If Next End With End Sub Private Sub UserForm_Activate() TextBox1_Change ListBox1.ListIndex = 0 End Sub

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

اخي العزيز ابو سليمان الحل المرفق بمعلوميه الاحداثيات اما اذا كنت تريد حساب المساحة عن طريق الاطوال فيجب عليك تقسيم الاشكال الي مثلثات. ثم حساب مساحة كل مثلث علي حده وتجميعها بعد ذلك مثلا ابعاد الحوش الذي تتكلم عنه ينقصها قياس احد اقطاره. ثم تقوم بحساب مساحة كل مثلث عن طريق المعادلة التالية. مساحة المثلث = الجذر التربيعي ل ح * (ح-س)*(ح-ص)*(ح-ع) حيث س، ص، ع هي اطوال اضلاع المثلث و ح هي نصف محيط المثلث (س+ص+ع)/2

السلام عليكم ممكن تجرب الاتي خيارات اكسل advanced General وشيل الصح عن الخيار الثالث ignore........(النسخة العربية تجاهل التطبيقات الاخرى.....) ثم ok

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

السلام عليكم و رحمة الله وبركاته اخي الحديثة جرب المرفق يتم اضافة اسم الصف اعلى الورقة ثم اسماء الغياب الحديثة.rar

السلام عليكم ورحمة الله وبركاته:- بالمرفق محاولة لقائمة تختصر لك الاسماء حسب جزء من الاسم انشاء الله تفي بالغرض , smartlist.rar

جرب الملف التاي وحاول اضافة لكود الى ملفك insert rows with his formula.zip

اضف هذا السطر في نهاية الكود : cmd.ForeColor = IIf(cmd.Caption = "اضافة وتعديل", vbBlue, vbRed) بالتوفيق

اخى الكريم اتفهم استخدامك لهذا الكم الكبير من التكست بوكس .. ولكن !!! جرب المرفق وابدى ملاحظاتك Book1.rar بالمرفق كود الترحيل فقط اما عن اكواد الاستدعاء والتعديل والحذف قم بفتح موضوع جديد لكل منهم تقبل تحياتى

جرب المرفق مع بعض التعديلات والإضافات... 11.rar

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

السلام عليكم ورحمة الله بعد مراجعة المعادلات وُجد خطأ في بعضها وتم تصحيحه في المرفق الجديد مع اعتبار عدم تكرار الأسماء وإضافة تحسينية بتنسيق شرطي (تلوين بالأخضر للصف الذي يحوي نتائج الاختبار)... أرجو أن ينال إعجابك... بن علية bjn3000.rar

الحلول المقدمة كلها بالمعادلات .. نسينا الأكواد هذا حل يغنيك عن معادلات الصفيف والمعادلات كلها والأعمدة المساعدة و وو .. وفر حجم ورقة العمل واستمتع بأداء أفضل مع الاكواد Private Sub Worksheet_Change(ByVal Target As Range) Dim A, I As Long If Target.Cells.Count > 1 Then Exit Sub If Target.Value = vbNullString Then Exit Sub If Intersect(Range("I2:J2"), Target) Is Nothing Then Exit Sub A = Range("A4", Range("A" & Rows.Count).End(xlUp)).Resize(, 3).Value With CreateObject("Scripting.Dictionary") For I = 1 To UBound(A, 1) If Target.Address = "$I$2" Then If A(I, 1) = Target.Value Then .Item(A(I, 2)) = Empty Else If A(I, 1) = Target(, 0).Value And A(I, 2) = Target.Value Then .Item(A(I, 3)) = Empty End If Next If .Count Then Target.Resize(, 2).Offset(, 1).Validation.Delete Target.Offset(, 1).Validation.Add 3, , , Join(.keys, ",") Application.EnableEvents = False Target.Offset(, 1).ClearContents Application.EnableEvents = True End If End With End Sub أرجو أن يفي بالغرض Validation Lists VBA.rar

بسم الله ما شاء الله حلول ممتازة أنا كنت مجهز ملفك من بدري لكن حصل انقطاع للكهرباء لمدة ساعتين فمنعت من المشاركة في الموضوع عموماً زيادةً في إثراء الموضوع إليك الملف التالي .. تم الاستعانة بعمودين مساعدين ..عمود لاستخراج القيم الفريدة لأسماء العملاء في العمود I بدايةً من الخلية I4 ، وذلك بناءً على قيمة الخلية K2 ، تم وضع معادلة الصفيف التالية =IFERROR(INDEX($B$4:$B$31,MATCH(0,COUNTIF($I$3:$I3,$B$4:$B$31)+($A$4:$A$31<>$K$2),0),COLUMN(A1)),"") معادلة صفيف تعني أنه بعد الإدخال يتم الضغط على Ctrl + Shift + Enter العمود الثاني المساعد هو العمود J بدايةً من الخلية J4 ، وذلك بناءً على الخليتين K2 وL2 تم استخراج أرقام القيد الغير مكررة بمعادلة الصفيف التالية =IFERROR(IF(I4="","",INDEX($C$4:$C$31,MATCH(0,COUNTIF($J$3:$J3,$C$4:$C$31)+($A$4:$A$31<>$K$2)+($B$4:$B$31<>$L$2),0),COLUMN(A1))),"") معادلة صفيف تعني أنه بعد الإدخال يتم الضغط على Ctrl + Shift + Enter ************************** المرحلة الثانية .. تحديد الخلية L2 ثم الذهاب إلى التبويب Data ثم Data Validation ثم اختيار List من القائمة ثم كتابة المعادلة التالية =OFFSET(I4,0,0,MATCH("",I4:I1000,0)-1,1) نفس الكلام مع الخلية المجاورة M2 =OFFSET(J4,0,0,MATCH("",J4:J1000,0)-1,1) أرجو أن أكون قد وفقت لتوصيل المعلومة تقبل تحياتي Validation Lists YasserKhalil.rar

السلام عليكم ورحمة الله أخي العزيز، بمعية أعمدة مساعدة ومعادلات تم عمل المطلوب... غير أنه لم تُراعى فيه التكرارات في القوائم المنسدلة (لا في اسم العميل ولا في رقم القيد).... بن علية bjn3000.rar

هذه احد طرق الحل لعلها تفى بالغرض ان كان ما تريد سأشرح لك كيف تفعلها جرب المرفق bjn3000_2.rar

السلام عليكم ورحمة الله أخي الكريم عبد العزيز، لا أقصد ما وضعته بل أقصد : TextBox1.Value = Format(TextBox1.Value, "#00.00") أو TextBox1.Value = Format(TextBox1, "#00.00") أخوك بن علية

السلام عليكم ورحمة الله وبركاته إخواني الأعزاء .. أقدم لكم بعون الله كل ما هو جديد ومفيد في عالم الإكسيل .. الموضوع اليوم عن النطاقات المعرفة Defined Names .. نبدأ بكيفية عمل نطاق معرف .. نقوم بتحديد الخلايا ثم في صندوق الاسم على يسار شريط المعادلات ننقر بالماوس نقرة واحدة ونكتب اسم للنطاق الذي تم تحديده .. وللإطلاع على النطاقات المسماة يمكن الدخول إلى التبويب Formulas ثم انقر على Name Manager لتطلع على النطاقات المسماة بالفعل ، ويمكنك تعديل النطاق من خلال Name Manager .. كما يمكنك حذف أي نطاق مسمى (الحذف يكون لاسم النطاق وليس للنطاق نفسه) الجديد: هو كيفية إخفاء أسماء هذه النطاقات (واللي يحضر عفريت يعرف يصرفه) ، وبالتالي يوجد أيضاً إظهار النطاقات المسماة في الملف المرفق. بالملف المرفق تم تسمية نطاقين بأسماء MyData و MyRange .. قم بالإطلاع على Name Manager قبل أن تضغط زر الأمر Hide Defined Names ثم بعد النقر على الإخفاء قم بالإطلاع على النطاقات المسماة ، لن تجدها في Name Manager (واحد عنده أمل إنها تكون موجودة ففتح صندوق الاسم Name Box اللي على شمال شريط المعادلات ..انسى انسى يا عمرو) اختفت النطاقات المسماة وانتهى أمر وجودها .. لإرجاع النطاقات المسماة يتم النقر على زر الأمر Unhide Defined Names فيعود كل شيء لطبيعته .. أعتقد أن الموضوع قد يكون جيد لحماية المصنف من المتطفلين من الإطلاع على النطاقات المسماة أرجو أن يفيدكم الموضوع ، تقبلوا تحياتي Hide Unhide Defined Names.rar

السادة أعضاء المنتدي الكرام السلام عليكم و رحمة الله و بركاتة مرفق لكم ملف يعمل فلترة للبيانات عن طريق 1. وضع تاريخ بدء الفلترة و تحديد مدة الفلترة المطلوبة 2. بمعلومية الاسم و أي معلومة أخري 3. بمعلومية أي معلومتين 4. عن طريق السنة أو السنة و الشهر أتمني أن أكون قد وفقت في هذا الملف و يحوز رضاكم Auto-Filter.rar

السلام عليكم ورحمة الله وبركاته تفضل اخى طاهر ................... ولكنى كنت امل ان تجرب ان تفعل ذلك بنفسك .............................. تقبل تحياتى جمعية خيرية1.rar

السلام عليكم ورحمة الله وبركاته اخى طاهر كل عام وانت والامه المسلمه بخير تم تعديل الملاحظات قم بتجربة المرفق جيدا تقبل تحياتى جمعية خيرية2.rar