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

للأسف سيكون هناك تضارب في النسخ التي سيتم تنزيلها ..أرى عبد العزيز 2013 وإمبارح أحمد منزل عدد 2 من الروابط واحد 2012 وواحد 2015 إخواني الرجاء من الأخ ياسر العربي الاستقرار على نسخة واحدة وبلغة واحدة وتفضل الإنجليزية ليكون العمل موحد ..يمكن بعدما نصل لمرحلة التمكن أن نجرب نسخ أخرى ولكن في مرحلة التعلم الرجاء الاستقرار على نسخة واحدة فقط

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

الحمد لله الذي بنعمته تتم الصالحات وجزيت خيراً أخي الكريم حراثي بمثل ما دعوت لي ..

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

بسم الله ما شاء الله عليك أبو عيد أعمالك رائعة وتدرس ... اسمح لي بإضافة بسيطة جداً إذا كان الأمر لا يزعجك .. بدلاً من وضع نفس الكود في كل ورقة عمل تريد تعقب التغيرات فيها يمكنك وضع الكود مرة واحدة فقط في حدث المصنف .. وتضيف سطر للشرط للتعامل مع أوراق محددة .. وبهذا يكتسب الكود مرونة كبيرة ليصبح الكود بهذا الشكل في نهاية الأمر Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim LR As Long If Sh.Name = "يناير" Or Sh.Name = "فبراير" Then LR = Sheets(3).Cells(Rows.Count, "A").End(xlUp).Row + 1 If Target.Column < 10 And Not IsEmpty(Target) Then With Sheets(3) .Cells(LR, 1) = ActiveSheet.Name .Cells(LR, 2) = Target.AddressLocal .Cells(LR, 3) = Target.Value .Cells(LR, 4) = [vv1].Value .Cells(LR, 5) = Format(Date, "dd-mm-yyyy") .Cells(LR, 6) = Format(Now, "h:mm:ss") End With End If End If End Sub Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) If Sh.Name = "يناير" Or Sh.Name = "فبراير" Then [vv1] = ActiveCell.Value End If End Sub والملف التالي فيه تطبيق الكود ... تقبل وافر تقديري واحترامي حمل الملف من هنا

تفضل أخي الكريم الملف التالي ... أرجو أن يفي بالغرض ويحل المشكلة إن شاء الله ... حمل من هنا

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

هل جربت إضافة السطر التالي في نهاية الكود UserForm1.Show .. إذا لم يعمل معك فأرجو إرفاق الملف للعمل عليه والإطلاع عليه بحيث تتضح الصورة

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

أخي الكريم هاني آرنست يمكن عمل ورقة عمل بشكل مؤقت تجمع بين ورقتي العمل ثم طباعة الورقة الجديدة وفي نهاية المطاف يتم حذف ورقة العمل المؤقتة .. هذه هي فكرة الكود Sub Test() Dim strAddress As String Application.ScreenUpdating = False On Error Resume Next Application.DisplayAlerts = False Sheets("Temp").Delete Application.DisplayAlerts = True On Error GoTo 0 Sheets("A").Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = "Temp" With Sheets("Temp") Sheets("B").Range("A3:C" & Sheets("B").Cells(Rows.Count, "A").End(xlUp).Row).Copy .Cells(3, .Cells(3, .Columns.Count).End(xlToLeft).Column) strAddress = .Range("A3").CurrentRegion.Address .PageSetup.PrintArea = strAddress .PrintPreview Application.DisplayAlerts = False .Delete Application.DisplayAlerts = True End With Application.Goto Sheets("A").Range("A1") Application.ScreenUpdating = True End Sub أرجو أن يكون المطلوب إن شاء الله وإليك الملف المرفق فيه تطبيق الكود .... تقبل تحياتي حمل الملف من هنا

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

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

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

أخي الكريم أبو عبد الواجد بالنسبة للخطأ يمكن تخطية باستخدام الدالة IFERROR .. على سبيل المثال هذه المعادلة =INDEX(السجل!$C$2:$AP$2,0,MATCH($B26,السجل!$C$4:$AN$4,0)+1) يمكن إضافة الدالة IFERROR بعد علامة يساوي ثم افتح قوس باستخدام Shift + 9 >> وفي نهاية المعادلة بعد القوس الأخير ضع فاصلة أو فاصلة منقوطة تبعاً للإعدادات لديك ثم ضع علامتي تنصيص ثم أغلق القوس باستخدام Shift + 0 لتصبح المعادلة بهذا الشكل =IFERROR(INDEX(السجل!$C$2:$AP$2,0,MATCH($B26,السجل!$C$4:$AN$4,0)+1),"")

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

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله ومع كل جديد في الإكسيل تقع عليه عيني اقوم على الفورم بإفادة إخواني به لنرتقي سوياً أقدم لكم اليوم طريقة نسخ بيانات نطاق محدد من مصنف مغلق ـ والموضوع إلى هنا ليس بجديد ... أم الجديد في الموضوع هو إمكانية نسخ النطاق إلى المصنف المفتوح الحالي بدون فتح المصنف المغلق على الإطلاق .. أي في الأكواد المستخدمة لن تجد كلمة Open ... إليكم الطريقة : قم بعمل مصنف وليكن باسم Sample.xlsx وضع به بعض البيانات في الـ 10 صفوف الأولى وفي الـ 10 أعمدة الأولى (هذا هو النطاق الذي سيتم نسخه إلى المصنف الحالي) ضع الكود التالي في موديول Sub GetDataFromClosedWorkbook() Dim FilePath$, Row&, Column&, Address$ 'Change Constants & Filepath Below To Suit '*************************************** Const FileName$ = "Sample.xlsx" Const SheetName$ = "Sheet1" Const NumRows& = 10 Const NumColumns& = 10 FilePath = ActiveWorkbook.Path & "\" '*************************************** DoEvents Application.ScreenUpdating = False If Dir(FilePath & FileName) = Empty Then MsgBox "The File " & FileName & " Was Not Found", , "File Doesn'T Exist" Exit Sub End If For Row = 1 To NumRows For Column = 1 To NumColumns Address = Cells(Row, Column).Address Cells(Row, Column) = GetData(FilePath, FileName, SheetName, Address) 'Columns.AutoFit Next Column Next Row ActiveWindow.DisplayZeros = False Application.ScreenUpdating = True End Sub Private Function GetData(Path, File, Sheet, Address) Dim Data$ Data = "'" & Path & "[" & File & "]" & Sheet & "'!" & Range(Address).Range("A1").Address(, , xlR1C1) GetData = ExecuteExcel4Macro(Data) End Function وإليكم الملف المرفق فيه تطبيق الأكواد ... . أرجو أن ينال الملف إعجابكم وتستفيدوا منه إن شاء الله تعالي ... حمل الملف من هنا تقبلوا وافر تقديري واحترامي

في انتظار وضع رابط البرنامج ..ويا ريت نتفق على نسخة واحدة فقط حتى لا يحدث تضارب ..

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

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

أخي الكريم محمود خليفة أهلاً بك في المنتدى ونورت بي إخوانك وننتظر منك المشاركة والمداومة في المنتدى تقبل تحياتي

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

وعليكم السلام أخي الكريم محمد عبد السلام إليك الملف المرفق تم وضع كود في حدث ورقة العمل المسماة Invoice >> كليك يمين على اسم ورقة العمل ثم اختر الأمر View Code ستجد الكود بعد التعديل ... يتم تفعيل الحدث بمجرد التعديل في العمود الخامس أي العمود E كما طلبت ويتم الترقيم في العمود الثالث أي العمود C ... حمل الملف من هنا

أخي الكريم أحمد ... أهلاً بك في المنتدى ونورت بين إخوانك يرجى تغيير اسم الظهور للغة العربية ..... ****************************** . إليك الملف المرفق التالي فيه ورقة عمل باسم Template تعتبر ورقة عمل كنموذج يمكنك نسخه .. ويتم النسخ إلى أي عدد من الأوراق طبقاُ للقائمة في ورقة عمل باسم List أي أن الماكرو يقوم بإنشاء أوراق عمل لكل القائمة .. Sub CopyTemplate() Dim LastRow As Long Dim Rng As Range Dim Ws As Worksheet Application.ScreenUpdating = False LastRow = Sheets("List").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row For Each Rng In Sheets("List").Range("A2:A" & LastRow) Set Ws = Nothing On Error Resume Next Set Ws = Worksheets(CStr(Rng)) On Error GoTo 0 If Ws Is Nothing Then Sheets("Template").Copy After:=Sheets(Sheets.Count) ActiveSheet.Name = CStr(Rng) End If Next Rng Application.ScreenUpdating = True End Sub وإليك الملف المرفق عله يفي بالغرض .. للتنفيذ قم بالضغط على Alt + F8 لتظهر لك قائمة الإجراءات اختر الإجراء وانقر على Run تقبل تحياتي حمل من هنا

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

أخي الحبيب عبد العزيز حمل السيريال من هنا