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

أخي الكريم يمكنك الاستغناء عن الأكواد الموجودة في حدث المصنف لأنها تتعامل مع جميع أوراق العمل وكذلك الإجراءات المرتبطة بها هذا الكود فقط يؤدي الغرض .. Sub ProtectActiveSheet() 'يقوم الكود بحماية ورقة العمل النشطة '----------------------------------- With ActiveSheet .Protect Password:="1", DrawingObjects:=True, Contents:=True, Scenarios:=True, UserInterfaceOnly:=True .EnableOutlining = True End With End Sub استبدل كلمة ActiveSheet باسم ورقة العمل المراد حمايتها ..

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

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

أخي وحبيبي إبراهيم شفاكم الله وعافاكم وألف لا بأس عليك لا بأس طهور إن شاء الله أسأل الله العظيم رب العرش العظيم أن يشفيك أسأل الله العظيم رب العرش العظيم أن يشفيك أسأل الله العظيم رب العرش العظيم أن يشفيك أسأل الله العظيم رب العرش العظيم أن يشفيك أسأل الله العظيم رب العرش العظيم أن يشفيك أسأل الله العظيم رب العرش العظيم أن يشفيك أسأل الله العظيم رب العرش العظيم أن يشفيك تقبل وافر تقديري واحترامي

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

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

أخي الحبيب إبراهيم فينك يا كبير ..غطسان فين اليومين دول؟! مفتقدين وجودك

وجزيت بمثله أخي الكريم مصطفى كمال

حل أروع وأجمل أخي أنو نصار تسلم الأيادي يا كبير تقبل وافر تقديري واحترامي

Sub TransferToAllSheets() 'Author : YasserKhalil 'Released : 02 - Dec. - 2015 'Use : The Code Transfers Data In Column B To Its Proper Sheet In A ' If Value Found In The Target Sheet, It Won't Be Transferred. '------------------------------------------------------------------------- Dim Cel As Range Dim LR As Long With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual End With For Each Cel In Sheets("Main").Range("A2:A" & Sheets("Main").Cells(Rows.Count, 1).End(xlUp).Row) If Evaluate("=ISREF('" & Cel.Value & "'!A1)") Then With Sheets("" & Cel.Value & "") LR = .Cells(Rows.Count, 1).End(xlUp).Row + 1 If Application.WorksheetFunction.CountIfs(.Range("A2:A" & LR), Cel.Offset(0, 1), .Range("C2:C" & LR), Cel.Offset(0, 3)) Then GoTo Skipper .Range("A" & LR).Resize(, 4).Value = Cel.Offset(0, 1).Resize(, 4).Value Cel.Offset(0, 10) = .Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row) End With End If Skipper: Next Cel With Application .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic End With End Sub Sub ClearAllSheets() Dim WS As Worksheet For Each WS In ThisWorkbook.Sheets If WS.Name <> "Main" Then WS.Range("A2:D1000").ClearContents Next WS Sheets("Main").Range("K2:K1000").ClearContents End Sub أخي الكريم جرب التعديل بالشكل التالي عله يفي بالغرض إليك الملف المرفق فيه ما تطلب إن شاء الله Transfer Data To Proper Sheet Without Duplicates YasserKhalil V2.rar

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

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

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

أخي الحبيب أبا الحسن والحسين كيف أصبحت ؟ أتمنى أن تكون في أحسن حال وعال العال جرب الكود التالي في حدث الفورم Private Sub UserForm_Initialize() Dim WS As Worksheet For Each WS In ThisWorkbook.Sheets If Left(WS.Name, 1) = "R" Or Left(WS.Name, 1) = "C" Then ComboBox1.AddItem WS.Name Next WS End Sub

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

أختي الفاضلة جربي الكود التالي Sub Find_Date() Dim C As Range, StrDate As Date, Rng As Range StrDate = CLng(Range("B3")) Set Rng = Union(Columns("E:E"), Range("E3:O3")) Set C = Rng.Find(What:=StrDate, LookIn:=xlFormulas) If Not C Is Nothing Then C.Select End Sub

أخي الكريم احمد أهلاً ومرحباً بك في المنتدى ونورت بين إخوانك تفضل الكود يوضع في حدث المصنف ويقوم بحماية جميع الأوراق بكلمة السر 1 اضغط Alt + F11 للدخول إلى محرر الأكواد ثم انقر دبل كليك في نافذة المشروع على ThisWorkbook ثم ضع الكود التالي .. احفظ الملف بصيغة Xlsm (لمزيد من التفاصيل يرجى الإطلاع على رابط موضوع بداية الطريق لانقاذ الغريق من هنا) تفضل Private Sub Workbook_Open() Dim WS As Worksheet For Each WS In ThisWorkbook.Sheets WS.Protect 1 Next WS End Sub تقبل تحياتي

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

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

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

جرب التعديل التالي عله يفي بالغرض Sub Transfer() Dim Cel As Range, LR As Long For Each Cel In Sheets("main").Range("A2:A" & Sheets("main").Cells(Rows.Count, 1).End(xlUp).Row) If Evaluate("=ISREF('" & Cel.Value & "'!A1)") Then With Sheets("" & Cel.Value & "") LR = IIf(IsEmpty(.Range("A1")), 1, .Cells(Rows.Count, 1).End(xlUp).Row + 1) If Application.WorksheetFunction.CountIf(.Range("A1:A" & LR), Cel.Offset(0, 1).Value) >= 1 Then GoTo Skipper Sheets("" & Cel.Value & "").Range("A" & LR) = Cel.Offset(0, 1).Value End With End If Skipper: Next Cel End Sub Transfer Data To Proper Sheet Without Duplicates YasserKhalil.rar

أخي الحبيب أبو يوسف ما المشكلة في المشاركة بالنسبة لك ؟؟ تقبل تحياتي

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

الموضوع بسيط إذاً هتلغي الحماية عن طريق صندوق الاختيار بوضع القيمة True بحيث يلغي الحماية المرتبطة بالنطاق وفي آخر الكود ترجع الحماية بتغيير القيمة إلى False Sub الصف_كل() [BK3].Value = "TRUE" Range("h1").Select ActiveCell.FormulaR1C1 = "1" ActiveSheet.PageSetup.PrintArea = "$h$3:$O$36" ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True Do ActiveCell = ActiveCell + 2 ActiveWindow.SelectedSheets.PrintPreview Loop Until ActiveCell.Value >= Range("N1").Value Range("A1").Select [BK3].Value = "FALSE" End Sub بس خلاص .. متنساش تغير كلمة PrintPreview إلى PrintOut أي طلب جديد ليس له علاقة بالموضوع يرجى طرحه في موضوع مستقل

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