مختار حسين محمود

الأخ الحبيب أبو حنين بارك الله فيكم الأخ الحبيب Creation World بالله عليك غير اسم الظهور الكود التالى للحفظ بناء على A1 وفى نفس مسا ر ملف الاكسل ومن غير مربع حوارى Sub PDF() Dim Rng As Range Dim fName As String fName = ThisWorkbook.Path & "\" & ActiveSheet.[a1].Value Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6)) Application.ScreenUpdating = False Rng.Activate Selection.ExportAsFixedFormat Type:=xlTypePDF, FileName:=fName, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True Sheets("ورقة1").Range("A1").Select Application.ScreenUpdating = True End Sub بالنسبة لطلبك الثانى الخاص بالصورة اعمل موضوع جديد لتعم الفائدة ومؤقتا شوف الموضوع ده http://www.officena.net/ib/index.php?showtopic=58031

الأخ الكريم الميسانى على الرغم من أن طلبك حيرنى إلا إنى طلعت منه بكود أعتقد أنه جميل وظريف هذا الكود هيخليك تتعلم سواقة العربيات بدرى بدرى لذلك سميته كود الفتيس على غرارعصا الفتيس فى العربيات عملت لك تعديلات وتنسيقات كان لابد منها فى الملف لتحقيق مطلبك اللى صدمنى من أول وهله أشوفه 3 اكواد فى الملف كود عمل pdf Sub PDFusingdialogbox() 'by mokhtar hussien '27/6/2015 Dim Rng As Range Dim i As Variant Dim Fname As String Fname = "" i = Application.GetSaveAsFilename(Fname, "PDF Files (*.pdf), *.pdf") Set Rng = Sheets("ورقة3").Range(Cells(1, 1), Cells(Rows.Count, 8)) Application.ScreenUpdating = False Rng.Activate Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=i, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True Sheets("ورقة3").Range("A1").Select Application.ScreenUpdating = True End Sub كود الفتيس وهو مسؤل عن نقل النطاق المتاح فى الورقة 2 الى الورقة 3 مع كل غيار تاخده بعصا الفتيس ( الـ Spinner ) الـ Spinner هنا أصبح ليه وظيفين تغيير البيانات فى الورقة 2 + يعمل عمل عصا الفتيس وده مش هتلاقيه فى أى حته فى العالم إلا عندنا فى الصعيد Sub Spinner6_Change() 'fetace code 'by mokhtar hussien '27/6/2015 Dim Rng As Range Set Rng = Sheets("ورقة2").Range("A1:H39") Application.ScreenUpdating = False Rng.Copy With ActiveWorkbook.Sheets("ورقة3").Cells(Rows.Count, "A").End(xlUp) .PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False End With Application.CutCopyMode = False Application.ScreenUpdating = True End Sub كود مسح البيانات من الورقة 3 اذا أخطأت فى التعامل مع عصا الفيس مش سايبك أنا أهه Sub del() 'by mokhtar hussien '27/6/2015 Application.ScreenUpdating = False Columns("A:H").Select With Selection .ClearContents .Borders.LineStyle = xlNone End With Range("a1").Select Application.ScreenUpdating = True End Sub المرفق used range as pdf using dialog box 2 by mokhtar .rar

السلام عليكم ورحمة الله وبركاته آخى وحبيبى فى الله وأستاذى ياسر خليل كله بفضل من الله ثم تشجيعك لى جازاكم الله خيرا الأخ الكريم أنس دروبي بارك الله فيك اذا كنت تريد حفظ الــ pdf فى نفس مسار ملف الاكسل استخدم الكود بالشكل التالى Sub PDFusingdialogbox() Dim Rng As Range Dim i As Variant Dim Fname As String Fname = ActiveWorkbook.Path & "\" & Left(ActiveWorkbook.Name, InStr(1, ActiveWorkbook.Name, ".", 1) - 1) & "(" & Format(Now, "DD-MM-YYYY") & ").pdf" i = Application.GetSaveAsFilename(Fname, "PDF Files (*.pdf), *.pdf") Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6)) Application.ScreenUpdating = False Rng.Activate Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=i, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True Sheets("ورقة1").Range("A1").Select Application.ScreenUpdating = True End Sub

الأستاذ الميسانى شىء طبيعى ظهور هذا الخطأ لأن أنت فلتها بنفسك A1 فارغة طبق الكود على ملف الأخ الكريم Creation Sub PDFusingdialogbox() Dim Rng As Range Dim i As Variant Dim Fname As String Fname = "Elmisani" ' ضع الاسم اللى يعجبك i = Application.GetSaveAsFilename(Fname, "PDF Files (*.pdf), *.pdf") Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6)) Application.ScreenUpdating = False Rng.Activate Selection.ExportAsFixedFormat Type:=xlTypePDF, FileName:=i, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True Sheets("ورقة1").Range("A1").Select Application.ScreenUpdating = True End Sub هذا بالنسبة للملاحظة الأولى الثانية والثالثة جرب الحفظ حتى مليون مرة بالكود التالى هو هو اللى فوق بس بنلعب باسم الملف براحتنا Sub PDFusingdialogbox() Dim Rng As Range Dim i As Variant Dim Fname As String Fname = Left(ActiveWorkbook.Name, InStr(1, ActiveWorkbook.Name, ".", 1) - 1) & "(" & Format(Now, "DD-MM-YYYY-hhmmss") & ").pdf" i = Application.GetSaveAsFilename(Fname, "PDF Files (*.pdf), *.pdf") Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6)) Application.ScreenUpdating = False Rng.Activate Selection.ExportAsFixedFormat Type:=xlTypePDF, FileName:=i, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True Sheets("ورقة1").Range("A1").Select Application.ScreenUpdating = True End Sub اذا كنت تريد وضع الاسم بنفسك فى الصندوق الحوارى استخدم الكود التالى هو هو بس بنلعب بالاسم زى ما قلت لك Sub PDFusingdialogbox222() Dim Rng As Range Dim i As Variant Dim Fname As String Fname = "" i = Application.GetSaveAsFilename(Fname, "PDF Files (*.pdf), *.pdf") Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6)) Application.ScreenUpdating = False Rng.Activate Selection.ExportAsFixedFormat Type:=xlTypePDF, FileName:=i, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True Sheets("ورقة1").Range("A1").Select Application.ScreenUpdating = True End Sub بالنسبة للمرفق أعتذر الليلة للصلاة كل سنة وأنتم جميعا أقرب لله

أخى وأستاذى الفاضل ياسر خليل نورت الموضوع هذا الكود البسيط كفيل بتحقيق طلبات الأستاذ الميسانى الكود بيعمل pdf من النطاق المتاح وأنت تحدد مكان الحفظ فقط مع فتح الـــ pdf Sub PDFusingdialogbox() Dim Rng As Range Dim i As Variant Dim fName As String fName = ActiveSheet.[a1].Value i = Application.GetSaveAsFilename(fName, "PDF Files (*.pdf), *.pdf") Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6)) Application.ScreenUpdating = False Rng.Activate Selection.ExportAsFixedFormat Type:=xlTypePDF, FileName:=i, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True Sheets("ورقة1").Range("A1").Select Application.ScreenUpdating = True End Sub تحياتى كل سنة وأنتم أقرب الى الله هو فين صاحب الموضوع الأخ الكريم Creation !!!!!!!!!!!!!

كل سنة وأنت طيب يا أبا بهاء الطلب الأول : للتعبئة والمسح :استخدم الكودين التاليين : Sub GenerateRandom() Range("A10:A210").FormulaR1C1 = "=RANDBETWEEN(1,12)" End Sub Sub DEL() Range("A10:A210") = "" End Sub تحياتى

الأستاذ الميسانى الملف هتلاقيه فى الــــ Documents

السلام عليكم جرب تتغيير السطر التالى فى الكود convert_pdf Set Rng = Range("a1:f17") بالسطر التالى Set Rng = Sheets("ورقة1").Range(Cells(1, 1), Cells(Rows.Count, 6)) الاعتماد هنا على النطاق المتاح من الخلية A1 حتى آخر خلية بها بيانات فى العمود 6 دون الاعتماد على الخليتين P2,P3 اعتبرهم مش موجودين ولا علاقة لهما بالكود تحياتى

بارك الله فيك أخى ياسر فتحى علمنى ازاى بتعمل الصور الجميلة دى ازاى بتخلى المشاركة رائعة ؟!! تحياتى

أخى أبا حنين بارك الله فيكم والحمد لله أننا توصلنا لحل يرضيك كل سنة وحضرتك طيب

السلام عليكم أنا هقولك على طريقة وحضرتك عليك التنفيذ 1 - ضع كود الدالة دى فى مديول جديد فى الملف Function INSERTPICTURE(ByVal PictureFullName As String, Optional ByVal PicWidth As Single = 200, Optional ByVal PicHeight As Single = 150) Dim CellActive As Range Dim picPicture As Object Set CellActive = Application.Caller For Each picPicture In CellActive.Parent.Pictures If picPicture.TopLeftCell.Address = CellActive.Address Then picPicture.Delete Exit For End If Next Set picPicture = CellActive.Parent.Pictures.Insert(PictureFullName) With picPicture .Left = CellActive.Left + 1 .Top = CellActive.Top + 1 .Width = PicWidth .Height = PicHeight End With End Function 2 - لتنفيذ الدالة : قم بعمل مجلد كمصدر للصور وليكن مثلاً على البارتشن H المجلد ده سميه أى اسم وليكن مثلا Sample Pictures ضع الصور في هذا المجلد الصور لاحظ أن صورك تكون بامتداد jpg كل صورة لها اسم والاسم ممكن يكون حروف أو رقم المهم لنفترض أن صورتين في هذا المجلد واحدة باسم mokhtar و الثانية باسم marmar في الخلية A1 مثلا قم بكتابة المعادلة التالية : =INSERTPICTURE("H:\Sample Pictures\mokhtar.jpg";200;150) لاحظ فى المعادلة اسم البارتشن H واسم المجلد واسم الصورة والامتداد وطول وعرض الصورة بمجرد كتابة المعادلة وتضغط انتر هتلاقى الصورة قدامك ظهرت عايز تنزل الصورة marmar شوف عايز تحطها جنب الأولى ولا تحتها براحنك أول خلية فاضية جنب الصورة الأولى أو تحتها ولتكن D1 اكتب المعادلة السابقة مع تغيير اسم الصورة: =INSERTPICTURE("H:\Sample Pictures\marmar.jpg";200;150) نزل باقى صورك بنفس الطريقة ظبط عرض الأعمدة وارتفاع الصفوف فى الشيت ليظهر التنسيق كما ينبغى عرض الأعمدة 10.5 ارتفاع الصفوف 21.75 ده غالبا يتماشى مع الصور 200X150 إن قابلتك مشكلة أرفق الملف والصور تحياتى

أعتقد أن هذا هو الكود النهائى يا أبا حنين الكود ينتج عنه ملف PDF واحد ويحتوى على النطاقات التى تحوى كلمة printing فقط وبدون تكرار النطاقات Sub SaveAsPDFB2CONFinal() Dim fName As String, i As Integer Dim AWS As Worksheet, RWS As Worksheet, ws As Worksheet Application.DisplayAlerts = False Application.ScreenUpdating = False Set AWS = ActiveSheet Set RWS = Worksheets.Add(After:=Sheets(Worksheets.Count)) fName = "D:\" & Worksheets(1).Range("A5").Value & " " & Worksheets(1).Range("D5").Value & ".pdf" For Each ws In Worksheets With ws If .Range("A1").Value = "printing" Then .Range("A1:F20").Copy RWS.Range("A" & RWS.Rows.Count).End(xlUp).Offset(1) End With Next ws RWS.ExportAsFixedFormat Type:=xlTypePDF, FileName:=fName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False RWS.Delete AWS.Activate Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub تفضل المرفق PDF Based 2 Condition Final .rar

الفكرة هى عمل شيت جديد نلصق فيه النطاقات التى تحوى كلمة printing ثم الحفظ بصيغة PDF هذا هو الكود بعد آخر تعديل توصلت اليه : Sub SaveAsPDFB2CON333() Application.DisplayAlerts = False Application.ScreenUpdating = False Dim fName As String Dim i As Integer Dim ws As Worksheet fName = Worksheets(1).Range("A5").Value & " " & Worksheets(1).Range(" D5 ").Value Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = "RESULT" For Each ws In ActiveWorkbook.Worksheets If ws.Name <> "RESULT" Then If ws.Range("A1") = "printing" Then ws.Activate ActiveSheet.Range("A1:f20").Copy Destination:=Sheets("RESULT").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) End If Next ws Sheets("RESULT").Activate ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:="D:\" & fName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False Sheets("RESULT").Select ActiveWindow.SelectedSheets.Delete Sheets("1").Select Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub الكود ينتج عنه ملف PDF واحد ويحتوى على النطاقات التى تحوى كلمة printing فقط لكن النطاقات تكررت مرتين . وسوف أحاول منع ذلك فى الوقت القريب بإذن الله تفضل المرفق PDFBased 2 Condition Version 2 .rar

أخى أبو حنين فى هذه الحالة اللى أنت طالبها لازم يكون فيه ملفين pdf والمشكلة أنك عايز ملف pdf واحد طب نعمل ايه فى الكلام ده ؟ّ! اصبر شوية صغيرة فيه فكرة بحاول تطبيقها وهنوصل بإذن الله ...... دعواتك لينا

أخى بو حنين أنا فهمت من كلامك أنك تريد pdf واحد من كل الأوراق التى فيها كلمة printing فى الخلية A1 وهذا الـــ pdf اسمه مكون من الخليتين A5 ,D5 فى الورقة 1 . اذا كان الأمر كذلك فقد حاولت التعديل على الكود ونتج pdf واحد ولكن ليس فيه كل الأوراق التى فيها كلمة printing فيه تكه عايز أجيبها ولكن مش جايه معاى وهى : عايزين نخلى الكود يحدد النطاقات التى بها كلمة printing فى كل الأورارق ومن ثمّ حفظ النطاقات المحددة بصيغة pdf فى ملف واحد . فلننتظر بعض الوقت وننتظر أيضا مشاركة الأخوة الأفاضل وإن شاء الله سنصل للحل

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

للأسف أعمل على MSO 2010 بس أعتقد العملية لا تختلف كثيرا فى 2003 هل جربت أن تحدد الخليتين وتدور على كلمة filter فى قوائم أو شريط أدوات 2003 ؟

ظلل أو حدد الخليتين ( اللى هما رأس العمودين ) ومن قائمة home اضغط sort & filter ثم الخيار filter بعدها ستجد علامات الفلترة ظهرت على الخليتين اللى حددتهم

أولا أهلا وسهلا بك بين أخوتك ثانيا عليك بقراءة التعليمات الخاصة بالأعضاء الجدد وهى فى صدر منتدى الاكسل ثالثا غيّر اسمك الى اللغة العربية ليسهل التواصل رابعا أرفق ملف للعمل عليه توضح فيه طلبك أكثر هل تريد منع الطباعة من شريط الأدوات وقائمة file وقصر عملية الطباعة على كود الطباعة فقط ؟ !!

أخى أبو زهرة مفيش مرفق للعمل عليه فى مشاركتك

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

أخى وأستاذى العزيز ياسر خليل شكرا لك ونحن نتعلم منك وسنظل بإذن الله أخى العزيز ياسر فتحى شكرا لك توقيعك روعة روعة

Sub SaveAsPDFB2CON() Application.DisplayAlerts = False Application.ScreenUpdating = False Dim fName As String Dim i As Integer For i = 1 To Sheets.Count With Worksheets(i) fName = Worksheets(i).Range("A5").Value & " " & Worksheets(i).Range(" D5 ").Value If Worksheets(i).Range("A1") = "printing" Then ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:="D:\" & fName, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False End If End With Next i Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub أخى بو حنين كل ورقة اكسل يوجد فيها كلمة printing فى الخلية A1 يتم حفظها بصيغة PDF باسم مكون من الخليتين A5 ,D5 لابد من وجود الشرطين الأول : كلمة printing فى الخلية A1 الثانى : بيانات فى الخليتين A5 ,D5 ملحوظة : كود الأستاذ عبدالله يعمل بكفاءة يبدو أنك أخطأت فى التطبيق . تحياتى للجميع PDF22222.rar

السلام عليكم ورحمة الله وبركاته كل سنة وحضراتكم بخير بمناسبة الشهر الفضيل أستأذن أستاذى الفاضل العزيز ياسر خليل فى هذه الاضافة اثراء للموضوع يمكن عمل كود واحد وزر واحد يعمل على اخقاء واظهار الصورة : Sub showhidepic() With ActiveSheet.Shapes("Rounded Rectangle 2").TextFrame2.TextRange.Characters If .Text = "Hide" Then .Text = "Show" ActiveSheet.Shapes("صورة 1").Visible = False Else .Text = "Hide" ActiveSheet.Shapes("صورة 1").Visible = True End If End With End Sub أخى وأستاذنا الفاضل ياسر خليل أقول لك نورت المنتدى تقبلوا جميعا تحياتى Hide Show Picture 2 .rar

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