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

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

الأخ الفاضل يرجى مراجعة هذا الرابط وتطبيق التوجيهات http://www.officena.net/ib/index.php?showtopic=60147 ولن يلتفت إليك الأخوة الأعضاء ما دمت لم تلتفت إلى التوجيهات (هااااام وضروري)

السلام عليكم ورحمة الله وبركاته إخواني الكرام جمعة مباركة عليكم أقدم لكم كود خفيف دمه ظريف .. الكود يقوم بعمل طريق مختصر للمصنف الحالي إلى سطح المكتب أو ما نسميه Shortcut، وكله بالكود Sub CreateShortCut() Dim oWSH As Object Dim oShortcut As Object Dim sPathDeskTop As String Set oWSH = CreateObject("WScript.Shell") sPathDeskTop = oWSH.SpecialFolders("Desktop") Set oShortcut = oWSH.CreateShortCut(sPathDeskTop & "\" & ActiveWorkbook.Name & ".lnk") With oShortcut .TargetPath = ActiveWorkbook.FullName .Save End With Set oWSH = Nothing End Sub هو دا الكود ..بس خلاص إليكم الملف المرفق قم بفك الملف المضغوط وضع الملف المفكوك في أي مسار على الحاسب الخاص بك ..وديه في الأدغال !! ونفذ الكود لتجد اختصار لمصنفك على سطح المكتب دمتم على طاعة الله ..ولا تنسونا من صالح دعائكم Create Shortcut On Desktop.rar

مصمم بردو على جازاكم مش جزاكم ولم تدلني أيهما صحيح أعتقد أنه بالإجماع جزاكم هي الكلمة الصحيحة ..وإلا أنتظر تصحيحك

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

اللهم صلي وسلم وبارك على نبي الرحمة جزيت خيراً على التذكرة .. وخلي بالك وراجع عشان صاحبك مش بيفوت ، فاهم يا كبير تقبل صباحي وتحياتي

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

الأخ الفاضل حليم الأخ الحبيب مختار أعتذر إليك إن كنت قد تدخلت في ردك ، وأحببت أن أهديك الموضوع الجديد http://www.officena.net/ib/index.php?showtopic=61116 دا هدية مني لمخنار (مختار وبس ..هدية خاصة مني لحبيبي) أشهد الله أني أحبك في الله تقبل هديتي (متبقاش غلس .. سامعك بتقول مش عايز منك هدايا)

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

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

الأخ الكريم محمود يرجى تغيير اسمك للغة العربية ليعبر عن شخصكم الكريم إليك الملف التالي بمجرد النقر المزودج في العمود B يتم تنفيذ الماكرو لنفرض أن لدينا الإجراء الفرعي التالي Sub Test() MsgBox "Hello Mahmoud" End Sub ثم يوضع الكود التالي في حدث ورقة العمل Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Column = 2 Then Call Test End If End Sub أرجو أن يكون المطلوب إن شاء الله Run Macro On Double Click.rar

أخي الحبيب مختار بارك الله فيك وجزاك الله كل خير في الماكرو المسمى SaveAs يوجد متغير باسم preName لم يعين له قيمة ..كما يوجد متغير آخر اسمه fileName تم تعيين قيمة له ولم يستخدم بالكود أمر آخر مطلوب معالجته ألا وهو أن يظل الملف الأصلي مفتوح بدون أن يغلق في حين أن النسخة الاحتياطية تغلق أي أي يتم عمل نسخة احتياطية في صمت Silent Mode تقبل تحياتي

الحمد لله الذي بنعمته تتم الصالحات والحمد لله أن تم المطلوب على خير .. وتصبح على خير أخي الكريم سعد .. أستودعك الله

الأخ الكريم مصطفى إليك الملف التالي Sub DeleteSheets() Dim I As Long Dim WS As Worksheet, SH As Worksheet Set WS = Sheets("بداية") Application.ScreenUpdating = False Application.DisplayAlerts = False For I = 3 To 10 For Each SH In Worksheets If WS.Cells(I, "B").Value = SH.Name Then SH.Delete Next SH Next I Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub تقبل تحياتي Delete Sheets Based On Range Values YasserKhalil.rar

الأخ الكريم سعد مشكور على توضيح طلبك .. ونعتذر إليك إذا كنا قد أرهقناك بكثرة توجيهاتنا إليك الملف التالي عله يفي بالغرض Sub SheetA() Dim WS As Worksheet, SH As Worksheet Dim lRow As Long, Cell As Range Set WS = Sheets("SQ"): Set SH = Sheets("A") lRow = 28 Application.ScreenUpdating = False For Each SH In Worksheets If SH.Name = "A" Or SH.Name = "B" Or SH.Name = "C" Or SH.Name = "D" Then SH.Range("B28:J230").ClearContents With WS For Each Cell In WS.Range("J2:J" & .Cells(Rows.Count, "J").End(xlUp).Row) If Cell.Value & Cell.Offset(, 1).Value = SH.Range("A27").Value Then SH.Cells(lRow, "B") = lRow - 27 SH.Cells(lRow, "C") = Cell.Offset(, -6) SH.Cells(lRow, "D") = Cell.Offset(, -3) lRow = lRow + 1 End If Next Cell End With End If lRow = 28 Next SH Application.ScreenUpdating = True End Sub تقبل تحياتي Grab Data Based On Conditions.rar

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

الأخ الفاضل عمرو طلبة إليك الملف التالي عله يفي بالغرض Sub LoopThroughAllWorkbooks() Dim FolderPath As String, FileName As String Dim WBK As Workbook Dim SH As Worksheet FolderPath = ThisWorkbook.Path & "\Collections\" FileName = Dir(FolderPath & "*.xl*") Application.ScreenUpdating = False Do While FileName <> "" Set WBK = Workbooks.Open(FolderPath & FileName) For Each SH In WBK.Worksheets If Not IsEmpty(SH.Range("A1")) And SH.Range("A1").Value = "شركة حياة للطاقة و المياه" Then SH.Range("A1").Value = "شركة حياة لخدمات المياه" End If Next SH WBK.Close SaveChanges:=True FileName = Dir() Loop Range("A1").Select Application.ScreenUpdating = True End Sub أرجو أن يفي بالغرض Loop Through All Workbooks To Change String.rar

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

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

أخي لا أعتقد أنه فيروس ربما تقوم بعملية نسخ لورقة العمل تلك ومن الطبيعي أن النسخ العادي سيقوم بنسخ ورقة العمل تماماً كما هي ، فتصبح الجديدة مثل ورقة العمل القديمة بما في ذلك الأخطاء الموجودة عموماً هذا كود آخر يمكنك من خلاله التخلص من كل صناديق النصوص في ورقة العمل النشطة Sub DeleteAllTextBoxes() 'يقوم الكود بحذف كل صناديق النصوص في ورقة العمل النشطة ActiveSheet.TextBoxes.Delete End Sub تقبل تحياتي

الاخ الكريم مصطفى فينك بقالك فترة مختفي (لعله خير) إليك الملف التالي رغم أنك لم توضح بالتفصيل طلبك ، ولكني حاولت التدقيق في الطلب حتى فهمت مرادك Sub CopySheets() Dim I As Long Dim WS As Worksheet, SH As Worksheet Set WS = Sheets("نسخ"): Set SH = Sheets("بداية") Application.ScreenUpdating = False For I = 3 To 10 If blnWorksheetExists(SH.Cells(I, "B")) Then GoTo 1 WS.Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = SH.Cells(I, "B").Value ActiveSheet.Range("B2").Value = SH.Cells(I, "B").Value 1 Next I SH.Activate Application.ScreenUpdating = True End Sub Function blnWorksheetExists(strWorksheet As String) As Boolean On Error Resume Next blnWorksheetExists = Not (ThisWorkbook.Worksheets(strWorksheet) Is Nothing) On Error GoTo 0 End Function تقبل تحياتي Copy Sheet Based On Range Values YasserKhalil.rar

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

أخي الفاضل تركي1 يرجى أولا تغيير اسمك للغة العربية لسهولة التواصل فيما يخص ملفك الأصلي ..كان من المفترض في بداية الأمر أن ترفق نموذج من الملف الأصلي بالكامل للتعامل مع الكود بما يناسب ملفك .. المشكلة أن الكود يتعامل مع أوراق العمل كلها باستثناء ما تم استثناؤه .. في هذا السطر تم الاستثناء If SH.Name <> "SQ" And SH.Name <> "ATTEND" Then قم بالتعديل على الكود وأضف أوراق العمل المراد استثناؤها من الحلقة التكرارية .. كما يجب أن تكون أوراق العمل الأخرى التي سيتم التعامل معها بنفس الشكل والهيئة تماماً حتى ينفذ الكود بشكل صحيح أترك لك مهمة تعديل الكود .. وأي استفسار آخر إن شاء الله ستجدني أجيبك

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

أخي الفاضل جرب الملف التالي عله يفي بالغرض Sub Tarhil() Dim WS As Worksheet, SH As Worksheet Dim lRowWS As Long, lRowSH As Long Set WS = Sheets("ورقة1"): Set SH = Sheets("ورقة2") lRowWS = ActiveCell.Row lRowSH = Application.WorksheetFunction.Match(WS.Range("C1").Value & " " & WS.Range("D1").Value, SH.Columns("E:E"), 0) SH.Cells(lRowSH, "B").Value = WS.Cells(lRowWS, "B").Value End Sub تقبل تحياتي ترحيل.rar