ياسر خليل أبو البراء

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Address = "$A$1" Then Dim X, WS As Worksheet X = Target.Value Set WS = Sheets("البيانات") If X + 3 > WS.Cells(Rows.Count, "A").End(xlUp).Row Then MsgBox "لقد أدخلت رقم أكبر من البيانات المتاحة في ورقة البيانات", 64: Exit Sub If X = "" Or X = 0 Then If MsgBox("هل تريد مسح البيانات الموجودة؟", vbYesNo) = vbYes Then Range("A3:G1000").ClearContents: Application.Goto Target: Exit Sub Else Application.Goto Target: Exit Sub End If End If Application.ScreenUpdating = False Range("A3:G1000").ClearContents WS.Range("A4:G" & X + 3).Copy Range("A3").PasteSpecial xlPasteValues Application.Goto Target Application.CutCopyMode = False Application.ScreenUpdating = True End If End Sub بارك الله فيك أخي الحبيب أبو عيد الأخ الكريم أبو أحمد هل المطلوب نسخ المعادلات أم تحقيق الهدف ..لأنني لاحظت أنك تقوم بنسخ البيانات عن طريق المعادلات ثم سحب المعادلات بالكود لتحقق الهدف أليس من الممكن تحقيق الهدف بدون اللجوء إلى المعادلات إليك الكود التالي يوضع في حدث ورقة العمل ..الكود قد يكون أطول من كود الأخ أبو عيد لأنني راعيت أن يراعي جميع الاحتمالات .. ماذا لو وضعت القيمة صفر في الخلية A1 أو مسحت محتوياتها أو وضعت رقم أكبر من الأرقام الموجودة في ورقة البيانات عموماً إليك الكود التالي عله يفي بالغرض

أخي الحبيب أبو نصار ما الحل لمشكلة الأداة Calendar >> هل لها حل مع أوفيس 2013 64 بت ؟

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

أخي الكريم أبو نصار اعذرني سأطرح عليك عدة أسئلة متتالية ..أولها هل الفورم المسمى Celndr_Ali له دور في الملف ؟؟ حيث أنه يظهر عندي فوورم فارغ لا يوجد عليه شيء أنا لدي أوفيس 2013 64 بت .. وعلى ما يبدو لي أنك استخدمت الأداة Calenadar التي أصبحت غير متوفرة في النسخ الحديثة ولا أدري ما السبب ؟ بالنسبة للأسطر التي أضيفت لحساب عدد مرات التكرار تعطي النتيجة صفر على الدوام

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

أخي الكريم خالد إليك التعديل التالي عله يفي بالغرض Edit UserForm.rar

أخي الكريم ابو راكان لا تدعو على النظام الذي أعمل عليه ...فأنا الآن صرت من عشاق هذا النظام الرائع والسريع جداً في التعامل مع نظام التشغيل والجهاز لأنه يستغل إمكانيات الجهاز بالكامل وكل مشكلة ولها حل إن شاء ربي إليك التعديل التالي ليوافق العمل على نظام 64 بت #If VBA7 Then Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare PtrSafe Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long Private Declare PtrSafe Function SetWindowPos Lib "User32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Declare PtrSafe Function GetWindowRect Lib "User32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long #Else Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowPos Lib "User32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Declare Function GetWindowRect Lib "User32" (ByVal hwnd As Long, lpRect As RECT) As Long #End If Private Const GWL_STYLE = (-16) Private Const WS_CAPTION = &HC00000 Private Const WS_MAXIMIZEBOX = &H10000 Private Const WS_MINIMIZEBOX = &H20000 Private Const WS_SYSMENU = &H80000 Private Enum ESetWindowPosStyles SWP_SHOWWINDOW = &H40 SWP_HIDEWINDOW = &H80 SWP_FRAMECHANGED = &H20 SWP_NOACTIVATE = &H10 SWP_NOCOPYBITS = &H100 SWP_NOMOVE = &H2 SWP_NOOWNERZORDER = &H200 SWP_NOREDRAW = &H8 SWP_NOREPOSITION = SWP_NOOWNERZORDER SWP_NOSIZE = &H1 SWP_NOZORDER = &H4 SWP_DRAWFRAME = SWP_FRAMECHANGED HWND_NOTOPMOST = -2 End Enum Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Sub ShowTitleBar(bShow As Boolean) Dim lStyle As Long Dim tRect As RECT Dim xlHnd As Long xlHnd = Application.hwnd GetWindowRect xlHnd, tRect If Not bShow Then lStyle = GetWindowLong(xlHnd, GWL_STYLE) lStyle = lStyle And Not WS_SYSMENU lStyle = lStyle And Not WS_MAXIMIZEBOX lStyle = lStyle And Not WS_MINIMIZEBOX lStyle = lStyle And Not WS_CAPTION Else lStyle = GetWindowLong(xlHnd, GWL_STYLE) lStyle = lStyle Or WS_SYSMENU lStyle = lStyle Or WS_MAXIMIZEBOX lStyle = lStyle Or WS_MINIMIZEBOX lStyle = lStyle Or WS_CAPTION End If SetWindowLong xlHnd, GWL_STYLE, lStyle Application.DisplayFullScreen = Not bShow SetWindowPos xlHnd, 0, tRect.Left, tRect.Top, tRect.Right - tRect.Left, tRect.Bottom - tRect.Top, SWP_NOREPOSITION Or SWP_NOZORDER Or SWP_FRAMECHANGED End Sub Sub Hide_Application_Title() ShowTitleBar False End Sub Sub Show_Application_Title() ShowTitleBar True End Sub

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

أخي وحبيبي في الله أحمد يعقوب نفتقد وجودك بيننا .. بس خلاص معنديش كلام تاني عشان ممكن أشخط فيك (طبعاً بهزر معاك ..)

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

أخي الغالي عبد العزيز البسكري بارك الله فيك وجعله في ميزان حسناتك ما أجمل البساطة (خصوصاً لو كانت مخلوطة بالبطاطا)

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

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

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

أخي الكريم ناصر يبدو أنني حصلت على الكتالوج بالفعل ههههه إليك التعديل في هذا السطر ليناسب طلبك With Sh.Range("A1:D20") بدلاً من السطر With Sh.UsedRange

أخي الكريم أبو راكان إليك الكود التالي يتم وضعه في موديول عادي Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowPos Lib "User32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Declare Function GetWindowRect Lib "User32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Const GWL_STYLE = (-16) Private Const WS_CAPTION = &HC00000 Private Const WS_MAXIMIZEBOX = &H10000 Private Const WS_MINIMIZEBOX = &H20000 Private Const WS_SYSMENU = &H80000 Private Enum ESetWindowPosStyles SWP_SHOWWINDOW = &H40 SWP_HIDEWINDOW = &H80 SWP_FRAMECHANGED = &H20 SWP_NOACTIVATE = &H10 SWP_NOCOPYBITS = &H100 SWP_NOMOVE = &H2 SWP_NOOWNERZORDER = &H200 SWP_NOREDRAW = &H8 SWP_NOREPOSITION = SWP_NOOWNERZORDER SWP_NOSIZE = &H1 SWP_NOZORDER = &H4 SWP_DRAWFRAME = SWP_FRAMECHANGED HWND_NOTOPMOST = -2 End Enum Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Sub ShowTitleBar(bShow As Boolean) Dim lStyle As Long Dim tRect As RECT Dim xlHnd As Long xlHnd = Application.hwnd GetWindowRect xlHnd, tRect If Not bShow Then lStyle = GetWindowLong(xlHnd, GWL_STYLE) lStyle = lStyle And Not WS_SYSMENU lStyle = lStyle And Not WS_MAXIMIZEBOX lStyle = lStyle And Not WS_MINIMIZEBOX lStyle = lStyle And Not WS_CAPTION Else lStyle = GetWindowLong(xlHnd, GWL_STYLE) lStyle = lStyle Or WS_SYSMENU lStyle = lStyle Or WS_MAXIMIZEBOX lStyle = lStyle Or WS_MINIMIZEBOX lStyle = lStyle Or WS_CAPTION End If SetWindowLong xlHnd, GWL_STYLE, lStyle Application.DisplayFullScreen = Not bShow SetWindowPos xlHnd, 0, tRect.Left, tRect.Top, tRect.Right - tRect.Left, tRect.Bottom - tRect.Top, SWP_NOREPOSITION Or SWP_NOZORDER Or SWP_FRAMECHANGED End Sub Sub Hide_Application_Title() ShowTitleBar False End Sub Sub Show_Application_Title() ShowTitleBar True End Sub يمكنك تنفيذ إخفاء شريط العنوان باستدعاء الماكرو المسمى Hide_Application_Title ولاظهار العنوان مرة أخرى استدعي الماكرو المسمى Show_Application_Title

وعليكم السلام ورحمة الله وبركاته أخي الكريم أبو راكان ما الغرض من إخفاء هذا الشريط بالتحديد؟

الكود يتم تفعيله عند حدوث تغيير في ورقة العمل (لأي ورقة عمل) يوضع الكود في حدث المصنف ThiisWorkbook ..

أخي الكريم أبو راكان هل جربت كلا الكودين ؟ وهل الكودين يؤديان نفس الغرض بالنسبة لك ...؟

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

أخي الكريم خالد إليك الملف التالي كنموذج يمكنك التعديل عليه بما يتلائم مع ملفك تقبل تحياتي UserForm TextBox Input YasserKhalil.rar

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

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

أخي الكريم ناصر (صحيح الكتالوج بتاعك مش معايا بس جرب التعديل التالي) ضع الكود في حدث المصنف .. سيتم تنفيذ الكود بمجرد التغيير في أي خلية في أي ورقة (وإن كنت لا أحبذ التعامل مع الأكواد بهذه الطريقة) Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Ap_A False With Sh.UsedRange .Columns.EntireColumn.AutoFit .Rows.EntireRow.AutoFit .Borders.Color = 1 With .Font .Name = "Times New Roman" .Size = 10 .Bold = True End With End With Ap_A True End Sub Private Function Ap_A(Bn As Boolean) With Application .Calculation = IIf(Bn, -4105, -4135) .ScreenUpdating = Bn .EnableEvents = Bn End With End Function

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