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

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

كيف لم ألاحظ هذا الموضوع المميز ؟؟ اعذرني أخي الغالي سليم على تأخري في الرد جزاك الله خير الجزاء وكل عام وأنت بخير

اضغط الملف أولاً ببرنامج ضغط مثل الوينرار ثم قم برفعه

أخي الفاضل جرب الكود بهذا الشكل Sub TransferDataToClosedWB() Dim WB As Workbook, SH As Worksheet Dim Cell As Range Dim strWB As String Dim LR_A As Long, LR_B As Long LR_A = IIf(Cells(Rows.Count, 1).End(xlUp).Row < 13, 13, Cells(Rows.Count, 1).End(xlUp).Row) strWB = ThisWorkbook.Path & "\" & "حسابات تجهيز.xlsm" Application.ScreenUpdating = False If Application.WorksheetFunction.CountA(Range("A13:A" & LR_A)) < 1 Then MsgBox "لا يوجد بيانات لترحيلها", vbInformation: Exit Sub On Error Resume Next If FileInUse(strWB) Then Set WB = Workbooks("حسابات تجهيز.xlsm") Else Set WB = Workbooks.Open(Filename:=strWB) End If For Each Cell In ThisWorkbook.Sheets("ترحيل").Range("A13:A" & LR_A) For Each SH In WB.Sheets If SH.Name = Cell.Value Then With SH LR_B = IIf(.Cells(Rows.Count, 4).End(xlUp).Row < 16, 16, .Cells(Rows.Count, 1).End(xlUp).Row + 1) Cell.Offset(, 2).Resize(, 5).Copy .Range("A" & LR_B).PasteSpecial xlPasteValues End With End If Next SH Next Cell WB.Sheets(1).Activate ThisWorkbook.Activate Application.CutCopyMode = False Application.ScreenUpdating = True End Sub Public Function FileInUse(sFileName) As Boolean On Error Resume Next Open sFileName For Binary Access Read Lock Read As #1 Close #1 FileInUse = IIf(Err.Number > 0, True, False) On Error GoTo 0 End Function تقبل تحياتي

الأخ الفاضل أبو إلياس إليك الكود بعد التصحيح .. من الأخطاء الظاهرة الخفية في الكود الذي قمت بكتابته كتابة رقم 1 بدلاً من حرف L في جملة xlup ويرجع ذلك إلى أنه عند كتابة حرف الـ L صغير بهذا الشكل l فإنه يشبه إلى حد كبير رقم 1 في محرر الأكواد .. وكذلك رقم 1 بدلاً من المتغير i يراعى عند كتابة الأكواد الدقة التااااااااامة ثم الدقة التامة .. التصحيح أصعب عندي من بناء الكود !! استغرق الأمر مني حوالي نصف ساعة لمعرفة الخطأ .. ظللت أنظر للكود ثم أنظر مرة أخرى ثم أنظر ولم ألاحظ أن حرف الـ L قد كتب بدلاً منه رقم 1 عموماً الحمد لله تم تدارك الخطأ .. ومعرفة مكمن المشكلة إليك الكود بعد التعديل Private Sub CommandButton1_Click() Dim MySH As Worksheet Dim I As Long, K As Long, R As Long, LR As Long Set MySH = Sheets("البيانات") K = 1 Columns("A:J").ClearContents For I = 3 To MySH.Cells(Rows.Count, 1).End(xlUp).Row LR = Cells(Rows.Count, 1).End(xlUp).Row + 1 For R = 1 To 10 If Me.Controls("CheckBox" & R) Then Cells(LR, K) = MySH.Cells(I, Me.Controls("CheckBox" & R).Caption) K = K + 1 End If Next R K = 1 Next I Unload Me End Sub لا تنسى أن تحدد أفضل إجابة .. كما لا تنسى أن تضغط على كلمة "أعجبني هذا" تقبل تحياتي :fff: Transfer Specific Columns By CheckBoxes On UserForm.rar

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

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

جرب الكود بهذا الشكل .. يوضع الكود في حدث ورقة العمل Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not Intersect(Selection, Range("J2:AN200")) Is Nothing Then If Target.Cells.Count > 1 Or IsEmpty(Cells(Target.Row, 2)) Then Exit Sub Else Target.Value = Cells(1, Target.Column).Value End If End If End Sub يرجى عدم تخصيص شخص بعينه عند طرح مسألة ما فالكل هنا شخص واحد على قلب رجل واحد يجمعهم منتدى واحد .. وأريد أن أسمع منك توحيد الواحد

أخي الغالي خالد الرشيدي بارك الله فيك على المجهود الجبار والمتميز قمت برفع ملفك على سيرفر المنتدى بدلاً من الروابط الخارجية VLOOKUP Rasheedy.rar

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

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

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

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

أخي طارق فقط احذف هذا السطر WB.Close SaveChanges:=True

ما المشكلة في الملف .. قم بتحديد كافة خلايا العمل أي تحديد كل الخلايا ونفذ الخطوات وتعديل الكود ليناسب طلبك بهذا الشكل إذا أردت العمل بالكود Sub CopyConditionalFormatting() Dim SH As Worksheet Sheets("Sheet1").Cells.Copy For Each SH In Worksheets If SH.Name <> "Sheet1" Then SH.Range("A1").PasteSpecial xlPasteFormats End If Next Application.CutCopyMode = False End Sub ولكن انتبه : يثقل الملف ويصبح بطيء إذا كثر التعامل مع التنسيق الشرطي .. وجبت النصيحة

أخي الكريم اللامع أهلاً بك في المنتدى ونورت بين إخوانك يرجى الإطلاع على رابط التوجيهات في الموضوعات المثبتة في المنتدى لتعرف كيفية التعامل مع المنتدى بشكل جيد كما يرجى تغيير اسم الظهور للغة العربية وستجد التفاصيل Details في رابط التوجيهات يمكن التحايل في المعادلة الموجودة في الخلية C5 لتصبح بهذا الشكل =WriteNo(INT(C4),0,"دينار") & " و"&" ( " & INT(MOD(C4,1)*1000) & " ) " & "درهم " تقبل تحياتي

صراحة لن أستطيع تجربة الكود الآن لأن عقلي توقف تقريباً .. فصلت جرب تغير السطر التالي LR_B = IIf(.Cells(Rows.Count, 4).End(xlUp).Row < 16, 16, .Cells(Rows.Count, 1).End(xlUp).Row + 1) ستقوم بوضع نقطة أمام كلمة Cells مرتين .. ليتلافى مسح البيانات القديمة جرب وضع السطر التالي قبل سطر إغلاق المصنف رابع سطر من تحت WB.Sheets(1).Activate ليفتح على أول شيت أما بالنسبة للنقطة الأخيرة فيمكنك تجربة الكود والكود أعتقد سيستغرق وقت مع البيانات الكثيرة لأن الكود يجب البيانات من مصنف آخر وفي داخل الكود يوجد حلقات تكرارية .. وهذا يسبب بطء في التنفيذ مع البيانات الكثيرة

مشكور أخي الحبيب سعد عابد على مرورك العطر بالموضوع تقبل وافر تقديري واحترامي

حل آخر بالاكواد .. يمكن تطبيق التنسيق الشرطي على ورقة العمل Sheet1 ثم تنفيذ الكود التالي الذي يؤدي نفس الغرض ويقوم بنسخ التنسيقات لجميع أوراق العمل الأخرى .. Sub CopyConditionalFormatting() Dim SH As Worksheet Sheets("Sheet1").Range("A1:B5").Copy For Each SH In Worksheets If SH.Name <> "Sheet1" Then SH.Range("A1:B5").PasteSpecial xlPasteFormats End If Next Application.CutCopyMode = False End Sub تقبل الله منا ومنكم

نعم أخي الحبيب أبو يوسف يمكن عمل ذلك وبدون أكواد ------------------------------------------------- نفترض أن لدينا 5 أوراق عمل Sheet1 إلى Sheet5 قم بتطبيق التنسيق الشرطي في ورقة عمل واحدة فقط وليكن مثلاً ورقة العمل Sheet1 في النطاق A1:B5 ** نحدد النطاق A1:B5 في ورقة العمل Sheet1 ** قم بالدخول على التبويب Home ثم Condiitonal Formatting ثم New Rule ثم Use a formula to determine which cells to format وطبق التنسيق الشرطي التالي =A1<25 ثم انقر الزر Format والتبويب Fill واختر أي لون ثم اضغط OK مرتين سيتم تلوين الأرقام أقل من 25 .. ** قم بتحديد النطاق A1:B5 في ورقة العمل Sheet1 ثم كليك يمين الأمر نسخ Copy ركز في الخطوة القادمة ** روح لورقة العمل Sheet2 ثم اضغط Ctrl من لوحة المفاتيح ثم حدد باقي أوراق العمل كلها ما عدا ورقة العمل Sheet1 لأنها الأساس الذي يتم النسخ منه بهذا تكون قد حددت كل أوراق العمل .. ** قم بالنقر داخل الخلية A1 ثم كليك يمين ثم لصق خاص Paste Special ثم اختر Formats أي نسخ التنسيقات فقط إليك الملف التالي لتتدرب على الخطوات المذكورة أي أن الملف المرفق ستقوم بتطبيق الخطوات عليه تقبلوا تحياتي Test Apply Conditional Formatting On Entire Workbook.rar

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

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

أخي الفاضل طارق يرجى عدم منادة شخص بعينه فكلنا هنا في المنتدى يد واحدة تبني كلها في صرح المنتدى - لابد أن تعلم ذلك جيداً - ومناداة شخص بعينه قد تنفر عضو لديه الحل من تقديم الحل (وجهة نظر لابد أن تحترم) عموماً جرب الكود التالي عله يفي بالغرض Sub TransferDataToClosedWB() Dim WB As Workbook, SH As Worksheet Dim Cell As Range Dim LR_A As Long, LR_B As Long LR_A = IIf(Cells(Rows.Count, 1).End(xlUp).Row < 13, 13, Cells(Rows.Count, 1).End(xlUp).Row) Application.ScreenUpdating = False If Application.WorksheetFunction.CountA(Range("A13:A" & LR_A)) < 1 Then MsgBox "لا يوجد بيانات لترحيلها", vbInformation: Exit Sub Set WB = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & "حسابات تجهيز.xlsm") For Each Cell In ThisWorkbook.Sheets("ترحيل").Range("A13:A" & LR_A) For Each SH In WB.Sheets If SH.Name = Cell.Value Then With SH LR_B = IIf(Cells(Rows.Count, 4).End(xlUp).Row < 16, 16, Cells(Rows.Count, 1).End(xlUp).Row + 1) Cell.Offset(, 2).Resize(, 5).Copy .Range("A" & LR_B).PasteSpecial xlPasteValues End With End If Next SH Next Cell WB.Close SaveChanges:=True Application.CutCopyMode = False Application.ScreenUpdating = True End Sub وإليك الملف المرفق الخاص بك فيه تطبيق الكود لاتنسى التوجيهات بتحديد أفضل إجابة والضغط على كلمة "أعجبني هذا" تقبل تحياتي الترحيل من ملف الى مف اخر.rar

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

أخي الحبيب أبو يوسف قم بإدراج اسم جديد في العمود الثاني أو قم بالنقر المزدوج في أي خلية داخل العمود الثاني ليتم تفعيل الكود