الصـقر

رائع يا استاذ احمد حلول متنوعه واكثر من رائعه تقبل تحياتى

( على حد علمى ان من عيوب القائمة المنسدله انها تسمح باللصق ) فى احد الخيارين امامى شوف ايه المناسب لك وانا تحت امرك الاول متابعه الرابط التالى http://www.officena.net/ib/index.php?showtopic=58026&page=2 المشاركة رقم 23 هل يناسبك هذا الحل ام انك تريد النسخ بالملف الثانى عمل فورم بحث بالاكواد والاستغناء عن القائمة المنسدله تقبل تحياتى

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

اخى الكريم يمكنك تعديل الاسم من الصفحه الشخصية الخاصه بك

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

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

استاذى الفاضل محمد الريفى مرورك اسعدنى جدا - و ارجو منك لا تحرمنا من اضافاتك بخصوص الترحيل تقبل منى وافر الاحترام والتقدير

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

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

اخى الكريم دى معادله اصبر على رزقك متستعجلش ان شاء الله هنشرحها

استاذ / محمد عبدالمجيد يالا يا كبير فيد الاخوة كما استفد انت بقيت استاذ كبير المنتدى زاد عالم اسمه محمد عبدالمجيد يالا ورينى الهمه وعلى فكرة انا مش ناسى البرنامج فينه عايز اشتغل عليه واستفيد منه شكرا على مرورك العطر وتقبل تحياتى

اخى الكريم بيف الدين حسام راجع الرابط التالى http://www.officena.net/ib/index.php?showtopic=58069&hl= وتقبل تحياتى

بسم الله الرحمن الرحيم الاخوة الزملاء فى هذا الصرح العظيم اقدم لكم الدرس الثانى من علمنى كيف اصطاد شرح مبسط عن كيفية عمل كود ترحيل من خلايا متفرقه بورقه عمل الى ورقة عمل اخرى بناء على طلب الاخ الكريم / بيف الدين حسام يريد معرفه كيفية عمل كود ترحيل من سند قبض الى شيت الخزينة كما هو موضح بالصور المطلوب ترحيل الخلايا المظلله باللون الاصفر بورقه عمل (توريد) الى ورقة عمل حركة الخزينة اولا : الضغط على ALT+F11 لفتح محرر الاكواد ثم من قائمة insert نختار مودويل جديد سيظهر لنا شاشة بيضه هنبداء بسم الله كتابة الكود Sub ترحيل() End Sub السطر الاول هو الاعلان عن بداية الكود sub يلية اسم الكود وهو ترحيل يلية () يعنى فتح قوس ثم غلقه فبمجرد كتابة السطر الاول سوف يتم ظهور السطر الثانى وهو End sub أنا عايز كل واحد يكتب الكود بنفسة مش ينسخ / من فضلك عايزك تكتب ثانيا : كتابة هذا السطر Sub ترحيل() Application.ScreenUpdating = False End Sub هذا السطر يعنى تثبيت الشاشه عند الترحيل ( يعنى عدم اهتزاز الشاشه اثناء تطبيق الكود ) ثالثا : ايه المطلوب هو ترحيل الخلايا المظلله باللون الاصفر بورقه عمل توريد الى ورقة عمل حركة الخزينة اذن الشيت اللى هتروح له البيانات هو شيت حركة الخزينة وهو اسمه حسب الملف المرفق وكما هو موضح بالصورة Sheet4 وليس حركة الخزينة ملحوظه/عند استخدم اسم شيت باى كود يفضل كتابة اسم الشيت الثابت كما هو بمحرر الاكواد لانه احتمال تغيير اسم الشيت من (حركة الخزينة) الى (قاعدة البيانات )مثلا فى هذه الحاله لا يعمل الكود نرجع للكود بتاعنا ونضيف الاتى Sub ترحيل() Application.ScreenUpdating = False With Sheet4 End With End Sub ما تم اضافته هو With Sheet4 كلمة With معناها الحرفى ( مع) أى مع الشيت Sheet4 لماذا استخدمنا Sheet4 وليس ( حركة الخزينة) لان لو كتبنا (حركة الخزينة With) وجيت حضرتك وغيرت اسم الشيت من حركة خزينة الى قاعدة البيانات مثلا لا يتغير اسم الشيت فى محرر الاكواد فهو هيظل ثابت باسم Sheet4 وفى هذه الحاله لا يعمل الكود لانه هيبجث عن شيت حركة الخزينة هيكون غير موجود لكن لو استخدمت With Sheet4 مهما تغير اسم الشيت هيشتغل الكود طيب اى شئ بفتحه فى الاكسيل لازم اقفله انا دلوقتى فتحت With Sheet4 اذن لا بد من قفل With بـــ End With رابعا : اضافه السطر التالى Sub ترحيل() Application.ScreenUpdating = False With Sheet4 Lr = .Cells(.Rows.Count, "D").End(xlUp).Row End With End Sub الجديد هو هذا السطر Lr = .Cells(.Rows.Count, "D").End(xlUp).Row عملنا متغير اسمه LR ويمكنك تغيير الى ما تريد من الاحرف حسب مزاجك حضرتك طيب وعرفناه انه عبارة عن اخر خليه بها بيانات فى عمود D من شيت حركة الخزينة وهى هنا كما هو بالصورة عليه الخلية D4 مكتوب فيها " رصيد افتتاحى" واحد هيقولى مش فاهم هوضح له اكتر مثلا عايز اقول ان " الاستاذ الكبير العلامه ياسر خليل العبقرى" = r فبدل كل شوية ما اكتب الجمله دى " الاستاذ الكبير العلامه ياسر خليل العبقرى " وتاخد منى وقت استعيض عنها بى r فقط / على طول الكود هيفهم معناها خامسا : اضافه السطر التالى Sub ترحيل() Application.ScreenUpdating = False With Sheet4 Lr = .Cells(.Rows.Count, "D").End(xlUp).Row .Cells(Lr + 1, "A") = [D8] End With End Sub ما هو الجديد الجديد هذا السطر [Cells(Lr + 1, "A") = [D8. ماذا يعنى الجزء الاول و هو.("Cells(Lr + 1, "A. (العمود, الصف)Cells. الصف هو Lr+1 يعنى Lr هى اخر صف فى العمود D من شيت حركة الخزينة فيه بيانات ( طيب انا عايز بقى السطر اللى بعده يبقى اقول Lr+1 طيب والعمود هو A وتم كتابته بين علمتى تنصيص "A" ( شيفت + حرف الطاء بالكيبور) طيب عمود A ده عايزين يروح له التاريخ اللى بسند القبض / والتاريخ اللى بسند القبض موجود بالخلية D8 صح اذن اقول [Cells(Lr + 1, "A") = [D8. وهكذا كما هو موضح بالكود يتم ترحيل كامل بيانات السند ثم نغلق With ب End With Sub ترحيل() Application.ScreenUpdating = False With Sheet4 Lr = .Cells(.Rows.Count, "D").End(xlUp).Row .Cells(Lr + 1, "A") = [D8] .Cells(Lr + 1, "B") = [G7] .Cells(Lr + 1, "D") = [D10] .Cells(Lr + 1, "G") = [d11] .Cells(Lr + 1, "E") = "=R[-1]C+RC[2]-RC[1]" End With End Sub اضغط على زر الترحيل ستجد البيانات تم ترحيلها ارجوا من الله ان اكون وفقت فى هذا الشرح ويستفيد منه الجميع ان احسنت فمن الله وما توفيقى الا بالله وان اخطأت فمن نفسى والشيطان وارجوا من الاساتذه الافاضل مراجعه الشرح وتصحيح ما به من أخطأ ولى رجاء من ادارة المنتدى جعل التعديل على الشرح متاح لى حتى يتثنى لى اضافه بعض الاشياء الاخرى تخص نفس الموضوع انا استكفيت بهذا القدر حتى يكون سهل على الاعضاء اللى عايز يطبق وان شاء الله سوف نكمل ما بدأناه تقبلوا منى وافر الاحترام والتقدير خزينة.zip

الاخت الكريمه الخطوات اللى ذكرتيه صحيح لكن مش عارفه انتى طبقتيها صح ام لا عموما اتبعى الخطوات التالية 1- حذف الكود اللى موجود فى حدث ThisWorkbook هتعملى دبل كليك على ThisWorkbook هتلاقى الكود اللى انتى قمتى بنسخه قبل كدا المطلوب بقى تحذفيه معلش هتعبك معايا (بالبلدى مش عايزين الخطوة دى مستغنيين عنها ) كدا حدث ThisWorkbook شاشة بيضا رجعت تانى بدون ما يكون فيها اى كود 2- المفترض انى عندك كودين دلوقتى كل كود فى مودويل صح طيب دبل كليك على كل مودويل واحذفى الكود اللى فيه تمام كدا الملف بدون اكواد هتردى تقولى دا فى كود من ضمنهم بتاع اخفاء الاشرطه والقوائم صح عادى احذفيهم بس 3- قومى بنسخ الكود التالى فى اى مودويل من اللى فاضيين انتى عندك 2 انسخى الكود ده والصقيه فى واحد من اى مودويل Public xx As Integer Public x As Integer Sub Auto_Open() Application.ScreenUpdating = False kh_wVisible True Application.ScreenUpdating = False ActiveWindow.DisplayWorkbookTabs = False Application.DisplayFormulaBar = False Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",false)" Call ToggleCutCopyAndPaste(False) Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Sub Auto_Close() Dim i As Integer kh_wVisible False ThisWorkbook.Close Not CBool(ThisWorkbook.Saved) Application.DisplayFormulaBar = True Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)" Call ToggleCutCopyAndPaste(True) End Sub Sub kh_wVisible(ibol As Boolean) Dim nBook As String nBook = ThisWorkbook.Name With Windows(nBook) If .Visible = Not ibol Then .Visible = ibol End With End Sub Sub unhide_toolbar() xx: Dim x x = InputBox("لأظهار القوائم يتطلب كلمة مرور" & Chr(13) & "الرجاء ادخال كلمة مرور", "كلمة مرور") If IsNull(x) Or x = "" Then GoTo xx If x = "111" Then ActiveWindow.DisplayWorkbookTabs = True Application.DisplayFormulaBar = True Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)" Else MsgBox "كلمة المرور غير صحيحه" & Chr(13) & " الرجاء اعادة ادخال كلمة المرور ", vbOKOnly End If End Sub Sub hide_toolbar() ActiveWindow.DisplayWorkbookTabs = False Application.DisplayFormulaBar = False Application.ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",false)" End Sub Sub تفعيل_النسخ() xx: Dim x x = InputBox("لتفعيل النسخ يتطلب" & Chr(13) & "الرجاء ادخال كلمة المرور", "كلمة مرور") If IsNull(x) Or x = "" Then GoTo xx If x = "111" Then Call ToggleCutCopyAndPaste(True) Else MsgBox "كلمة المرور غير صحيحه" & Chr(13) & " الرجاء اعادة ادخال كلمة المرور ", vbOKOnly End If End Sub Sub منع_النسخ() Call ToggleCutCopyAndPaste(False) End Sub 4-قومى بنسخ الكود التالى والصقيه فى المودويل التانى Option Explicit Sub ToggleCutCopyAndPaste(Allow As Boolean) 'Activate/deactivate cut, copy, paste and pastespecial menu items Call EnableMenuItem(21, Allow) ' cut Call EnableMenuItem(19, Allow) ' copy Call EnableMenuItem(22, Allow) ' paste Call EnableMenuItem(755, Allow) ' pastespecial 'Activate/deactivate drag and drop ability Application.CellDragAndDrop = Allow 'Activate/deactivate cut, copy, paste and pastespecial shortcut keys With Application Select Case Allow Case Is = False .OnKey "^c", "CutCopyPasteDisabled" .OnKey "^v", "CutCopyPasteDisabled" .OnKey "^x", "CutCopyPasteDisabled" .OnKey "+{DEL}", "CutCopyPasteDisabled" .OnKey "^{INSERT}", "CutCopyPasteDisabled" Case Is = True .OnKey "^c" .OnKey "^v" .OnKey "^x" .OnKey "+{DEL}" .OnKey "^{INSERT}" End Select End With End Sub Sub EnableMenuItem(ctlId As Integer, Enabled As Boolean) 'Activate/Deactivate specific menu item Dim cBar As CommandBar Dim cBarCtrl As CommandBarControl For Each cBar In Application.CommandBars If cBar.Name <> "Clipboard" Then Set cBarCtrl = cBar.FindControl(ID:=ctlId, recursive:=True) If Not cBarCtrl Is Nothing Then cBarCtrl.Enabled = Enabled End If Next End Sub Sub CutCopyPasteDisabled() 'Inform user that the functions have been disabled MsgBox "نأسف تم تعطيل النسخ واللصق والحذف بالملف!" End Sub 5-انتى كان عندك زرين واحد بتاع اظهار القوائم والثانى بتاع اخفاء القوائم دلوقتى هتعملى زرين كمان علشان يكونو 4 ازرار الزرين الجداد دول واحد هتعينى علية ماكرو تفعيل_النسخ ( يعنى هتقفى على الزر كليك يمين هتظهر قائمة اختارى تعيين ماكرو ثم هتظهر قائمة اختارى تفعيل_ النسخ) والثانى هتعينى عليه ماكرو منع _النسخ ( يعنى هتقفى على الزر كليك يمين هتظهر قائمة اخارى تعيين ماكرو ثم هتظهر قائمة اختارى منع_ النسخ) جربى وعلمينى بالنتيجة تقبلى تحياتى مرفق ملف للتطبيق اخفاء شريط الصفحات - Copy.zip

لما تعملى ALT +f11 هيفتح معك محرر الاكواد شوفى الصورة دى لما تعملى دبل كليك على ThisWorkbook هيفتح معك شاشة بيضه انسخى الكود الثانى فيها

انتى حطيت الكود الاول فى مودويل جديد والكود الثانى فى حدث الملف ThisWorkbook ( اعملى دبل كليك على ThisWorkbook هيفتح معك شاشة بيضه انسخى الكود الثانى فيها)

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

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

اخى الكريم حسب ما فهمت قم بنسخ المعادله التالية فى الخليه C2 =A2+14 تقبل تحياتى

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

الاخت الكريمة نصيحه مهمه جدا جدا اعملى نسخ للملف اللى انتى عايزة تشتغلى علية واشتغلى على الكوبى علشان لو حصل اى شئ يكون الاصلى موجود ولو ظبط الكود يبقى تمام ثانيا الخطوات 1- اول شئ هنعملى ادراج مودويل جديد وتنسخى الكود ده فيه Option Explicit Sub ToggleCutCopyAndPaste(Allow As Boolean) 'Activate/deactivate cut, copy, paste and pastespecial menu items Call EnableMenuItem(21, Allow) ' cut Call EnableMenuItem(19, Allow) ' copy Call EnableMenuItem(22, Allow) ' paste Call EnableMenuItem(755, Allow) ' pastespecial 'Activate/deactivate drag and drop ability Application.CellDragAndDrop = Allow 'Activate/deactivate cut, copy, paste and pastespecial shortcut keys With Application Select Case Allow Case Is = False .OnKey "^c", "CutCopyPasteDisabled" .OnKey "^v", "CutCopyPasteDisabled" .OnKey "^x", "CutCopyPasteDisabled" .OnKey "+{DEL}", "CutCopyPasteDisabled" .OnKey "^{INSERT}", "CutCopyPasteDisabled" Case Is = True .OnKey "^c" .OnKey "^v" .OnKey "^x" .OnKey "+{DEL}" .OnKey "^{INSERT}" End Select End With End Sub Sub EnableMenuItem(ctlId As Integer, Enabled As Boolean) 'Activate/Deactivate specific menu item Dim cBar As CommandBar Dim cBarCtrl As CommandBarControl For Each cBar In Application.CommandBars If cBar.Name <> "Clipboard" Then Set cBarCtrl = cBar.FindControl(ID:=ctlId, recursive:=True) If Not cBarCtrl Is Nothing Then cBarCtrl.Enabled = Enabled End If Next End Sub Sub CutCopyPasteDisabled() 'Inform user that the functions have been disabled MsgBox "Sorry! Cutting, copying and pasting have been disabled in this workbook!" End Sub ثانيا هتنسخى الكود التالى وتلصقية فى حدث ThisWorkbook حدث ThisWorkbook اتبعى تعليمات الصورة Option Explicit Private Sub Workbook_Activate() Call ToggleCutCopyAndPaste(False) End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) Call ToggleCutCopyAndPaste(True) End Sub Private Sub Workbook_Deactivate() Call ToggleCutCopyAndPaste(True) End Sub Private Sub Workbook_Open() Call ToggleCutCopyAndPaste(False) End Sub Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) If SaveAsUI = True Then Me.Save Cancel = True End If End Sub واهم شئ تعملى على نسخه من الملف وليس الملف الاصلى الين التاكد من ان الكود تمام زى ما انتى عايزة جربى وعلمينى بالنتيجة تقبل تحياتى

الاخت الكريمة راجعى الرابط التالى http://www.officena.net/ib/index.php?showtopic=40743&hl=%2B%D9%85%D9%86%D8%B9+%2B%D8%A7%D9%84%D9%86%D8%B3%D8%AE المشاركة رقم 4 كود للرائع عبدالله المجرب تقبلى تحياتى

اخى الكريم راجع الرابط التالى يمكن يفيدك http://www.officena.net/ib/index.php?showtopic=56235&hl= تقبل تحياتى

حضرتك دى معادله IF مع And مش كود تقبل تحياتى

اخى الكريم اين الملف قم بضغط الملف ببرنامج وينرار ثم ارفعه بالمشاركة