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

أخي الكريم أبو عبد الواجد أخي العزيز جمال (يرجى تغيير اسم الظهور للغة العربية) بالنسبة لطلبك تم إفراد موضوع كامل حول طلبك لمزيد من الاستفادة ، حيث أن الموضوعات الرئيسية تكون أيسر للباحث فيما بعد من المشاركات الفرعية رابط الموضوع من هنا

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله لطالما أردت طرح هذا الموضوع الهام جداً والشيق جداً والمفيد جداً .. ولكن يبدو أن الزهايمر يلعب دوراً هاماً في حياتي .. عموماً ذكرني عنوان موضوع رأيته الآن بهذا الموضوع ، فأحببت أن أشارككم هذا الكود الرائع والمتميز .. الكود يقوم بالمهام التالية .. في بداية تنفيذ الكود يمكنك الكود من اختيار الطابعة المطلوب الطباعة عليها .. من خلال الصور سأقوم بالطباعة على ملف بامتداد XPS .. حتى لا أهدر أوراقي (سامحوني .. دا مش بخل دا حرص مش كدا ولا ايه يا فلاحجي (لأنه أكتر واحد هيفهمني )) حسناً رأيتم الصورة معبرة ..أليست كذلك؟ نقرنا على زر الأمر PRINT ...فظهرت نافذة تتيح لنا إمكانية اختيار الطابعة ثم نضغط أوك لننتقل للنافذة التالية في النافذة التالية يتيح الكود كتابة عدد النسخ المراد طباعتها وبشكل افتراضي يكون عدد النسخ نسخة واحدة فقط ، ويمكن تغيير عدد النسخ المطلوبة هنا تظهر لك أوراق العمل الموجودة في المصنف عدا ورقة العمل النشطة المسماة Data ، يمكنك الكود من اختيار أوراق العمل المراد طباعتها بكل سهولة ثم أخيراً يتم تنفيذ أمر الطباعة ..في المثال الموضح سأقوم بتنفيذ أمر الطباعة لملف بامتداد XPS .. حيث يتم كتابة اسم الملف وتحديد المسار الذي سيحفظ فيه الملف ثم اوك قمت بتحديد مسار حفظ الملف بامتداد XPS على سطح المكتب وها هو الملف وقد طبع ورقتي العمل Sheet1 و Sheet3 فقط ، لأنني حددتهما من خلال النوافذ التي تظهر وأخيراً إليكم الكود الرائع الذي يقوم بكل هذه المهام الرائعة Sub PrintSelectedSheets() Dim I As Integer Dim TopPos As Integer Dim SheetCount As Integer Dim PrintDlg As DialogSheet Dim CurrentSheet As Worksheet Dim Cb As CheckBox Dim Numcop As Long Dim Cnt As Integer Dim X As String Application.Dialogs(xlDialogPrinterSetup).Show Application.ScreenUpdating = False If ActiveWorkbook.ProtectStructure Then MsgBox "المصنف محمي", vbCritical Exit Sub End If Set CurrentSheet = ActiveSheet X = CurrentSheet.Name Set PrintDlg = ActiveWorkbook.DialogSheets.Add SheetCount = 0 TopPos = 40 For I = 1 To ActiveWorkbook.Worksheets.Count Set CurrentSheet = ActiveWorkbook.Worksheets(I) If Application.CountA(CurrentSheet.Cells) <> 0 And CurrentSheet.Visible Then SheetCount = SheetCount + 1 PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5 PrintDlg.CheckBoxes(SheetCount).Text = CurrentSheet.Name TopPos = TopPos + 13 End If Next I PrintDlg.Buttons.Left = 240 With PrintDlg.DialogFrame .Height = Application.Max(68, PrintDlg.DialogFrame.Top + TopPos - 34) .Width = 230 .Caption = "اختر أوراق العمل المراد طباعتها" End With PrintDlg.Buttons("Button 2").BringToFront PrintDlg.Buttons("Button 3").BringToFront Numcop = Application.InputBox("أدخل عدد النسخ للطباعة:", "كم عدد النسخ?", 1, Type:=1) If Numcop = 0 Then ElseIf Len(Numcop) > 0 Then End If CurrentSheet.Activate Application.ScreenUpdating = True If SheetCount <> 0 Then If PrintDlg.Show Then For Each Cb In PrintDlg.CheckBoxes If Cb.Value = xlOn Then If Cnt = 0 Then Worksheets(Cb.Caption).Select Else Worksheets(Cb.Caption).Select Replace:=False End If Cnt = Cnt + 1 End If Next Cb ActiveWindow.SelectedSheets.PrintOut copies:=Numcop End If Else MsgBox "كل أوراق العمل فارغة", 64 End If Application.DisplayAlerts = False PrintDlg.Delete Sheets(X).Select End Sub تقبلوا جميعاً وافر تقديري واحترامي حمل الملف من هنا تحميلك للملف يدعم صاحب الموضوع .. فلا تبخل بدقيقة من وقتك .. وللعلم يمكنك عدم تحميل الملف ونسخ الكود في موديول في المصنف الخاص بك ، وستجد الكود جاهز للعمل لديك بدون تحميل الملف .. دمتم على طاعة الله ...

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

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

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

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

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

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

وجزيت خيراً أخي وحبيبي حسام عيسى صقر المنتدى نورت الموضوع بردك الجميل

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

أخي الحبيب أبو عبد الرحمن .. أنا بدأت أتوه في الموضوع بصراحة ونظراً لضيق وقتي أستسمحك في إرفاق آخر نسخة من الملف المراد العمل عليها ... أعتذر إليك .. تقبل تحياتي

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

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

بارك الله فيك أخي الكريم عبد الله فاروق على إحياء الموضوعات القديمة ليستفيد منه الأعضاء الجدد والقدامي إليك دالة معرفة شبيهة لما قدمت في المشاركة الأولى Function SheetName(rCell As Range, Optional UseAsRef As Boolean) As String Application.Volatile If UseAsRef = True Then SheetName = "'" & rCell.Parent.Name & "'!" Else SheetName = rCell.Parent.Name End If End Function لاستخدام الدالة .. قم في أي خلية بوضع المعادلة التالية =SheetName(A1) تقبل تحياتي

نسأل الله العفو والعافية لأختنا الفاضلة أم عبد الله ، فكم تعلمنا منها الكثير غفر الله لنا ولها

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

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

أخي الكريم جرب الكود بهذا الشكل Sub مستطيلمستديرالزوايا6_Click() Dim Ls As Long, LR As Long Dim Ws As Worksheet Set Ws = Sheets("فاتوره") Ls = Ws.Cells(Rows.Count, 4).End(xlUp).Row LR = Ws.Cells(Rows.Count, 2).End(xlUp).Row + 1 Application.ScreenUpdating = False Range("B7:O" & Ls).Copy Ws.Cells(LR, 2).PasteSpecial Paste:=xlPasteValues On Error Resume Next Range("B7:O" & Ls).SpecialCells(xlCellTypeConstants, 23).ClearContents Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox ("تم بحمد الله ترحيل فاتورة " & u) End Sub تقبل تحياتي

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

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

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

أخي الكريم الخلل سببه عدم ضبط نتائج المعادلة لديك حيث يظهر الخطأ NA لديك ولعلاج الخطأ قم بإصلاح المعادلة في الخلية B2 بهذا الشكل =IFERROR(VLOOKUP(A2,السعر,2,FALSE),"") ثم قم بسحب المعادلة ونفذ الكود مرة أخرى ... *********************************** بالنسبة لكود الخلاصة Test قم بتغيير السطر التالي LR = Ws.Cells(Rows.Count, "B").End(xlUp).Row إلى السطر التالي LR = Ws.Cells(54, "B").End(xlUp).Row تقبل تحياتي

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

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

أخي الكريم قم بالذهاب إلى قائمة Tools ثم References ثم أزل علامة الصح بجانب الخيار Missing الذي يظهر في الصورة ، حيث أن المكتبة مفقودة مما يسبب ظهور الخطأ لديكم تقبل تحياتي