Yasser Fathi Albanna

اخى الحبيب يمكنك الرجوع إلى الرابط التالى http://www.officena.net/ib/index.php?showtopic=55481&hl=%D8%A7%D9%84%D8%AD%D8%A7%D8%B3%D8%A8%D8%A9

سلمت يداك أخى الحبيب أ / سليم حاصبيا هذا هو المطلوب جزاك الله كل خير

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

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

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

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

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

Create Index page with hyperlinks to sheets Sub CreateIndex() Dim wSheet As Worksheet Dim l As Long l = 1 With Me .Columns(1).ClearContents .Cells(1, 1) = "INDEX" .Cells(1, 1).Name = "Index" End With For Each wSheet In Worksheets If wSheet.Name <> Me.Name Then l = l + 1 With wSheet .Range("A1").Name = "Start" & wSheet.Index .Hyperlinks.Add Anchor:=.Range("A1"), Address:="", SubAddress:= _ "Index", TextToDisplay:="Go to Index Page" ' Change "A1" in the line above to the cell address where you want to put link to Index page End With Me.Hyperlinks.Add Anchor:=Me.Cells(l, 1), Address:="", SubAddress:="Start" _ & wSheet.Index, TextToDisplay:=wSheet.Name End If Next wSheet End Sub

حاضر أخى ماجد2014 من عنيا

أخى ahmeditoo سيتم إنشاء الله فى اقريب العاجل عمل المطلوب شكرا لك

Export Excel Charts to PowerPoint Option Explicit Function getPPPres() As PowerPoint.Presentation Dim PPApp As PowerPoint.Application 'Reference instance of PowerPoint On Error Resume Next 'Check whether PowerPoint is running Set PPApp = GetObject(, "PowerPoint.Application") If PPApp Is Nothing Then 'PowerPoint is not running, create new instance Set PPApp = CreateObject("PowerPoint.Application") 'For automation to work, PowerPoint must be visible PPApp.Visible = True End If On Error GoTo 0 'Reference presentation and slide On Error Resume Next If PPApp.Windows.Count > 0 Then 'There is at least one presentation 'Use existing presentation Set getPPPres = PPApp.ActivePresentation Else 'There are no presentations 'Create New Presentation Set getPPPres = PPApp.Presentations.Add End If Set PPApp = Nothing End Function Function getNewSlide(PPPres As PowerPoint.Presentation) As PowerPoint.Slide Set getNewSlide = PPPres.Slides.Add(PPPres.Slides.Count + 1, ppLayoutBlank) End Function Sub ExportChartsToPPT(wksChartsFromSheet As Worksheet) Dim PPPres As PowerPoint.Presentation Dim PPSlide As PowerPoint.Slide Dim cht As ChartObject If wksChartsFromSheet.ChartObjects.Count = 0 Then MsgBox "No Chart to Export to Powerpoint", vbInformation, "" Exit Sub End If Set PPPres = getPPPres ' If PPPres.Slides.Count = 0 Then ' Set PPSlide = getNewSlide(PPPres) ' End If For Each cht In wksChartsFromSheet.ChartObjects Set PPSlide = getNewSlide(PPPres) cht.CopyPicture PPSlide.Select PPSlide.Shapes.Paste.Select PPSlide.Application.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True PPSlide.Application.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True PPSlide.Select Next cht Set cht = Nothing Set PPSlide = Nothing Set PPPres = Nothing End Sub Sub TestExecute() Call ExportChartsToPPT(Sheet2) End Sub

تفضل أخى لعله المطلوب Sub CopyCommentsToWord() 'Update 20140325 Dim xComment As Comment Dim wApp As Object On Error Resume Next Set wApp = GetObject(, "Word.Application") If Err.Number <> 0 Then Err.Clear Set wApp = CreateObject("Word.Application") End If wApp.Visible = True wApp.Documents.Add DocumentType:=0 For Each xComment In Application.ActiveSheet.Comments wApp.Selection.TypeText xComment.Parent.Address & vbTab & xComment.Text wApp.Selection.TypeParagraph Next Set wApp = Nothing End Sub وجرب دا أيضا Sub Test() Call CopyToWord(Sheet1.Range("A1:D10")) End Sub Sub CopyToWord(rngCopy As Range) Dim appWD As Object 'Word.Application Dim arr() Dim lngRow As Long Dim lngCol As Long arr() = rngCopy Set appWD = CreateObject("Word.Application.8") Application.ScreenUpdating = False appWD.Documents.Add For lngRow = 1 To UBound(arr(), 1) For lngCol = 1 To UBound(arr(), 2) If lngCol = UBound(arr(), 2) Then appWD.Selection.typetext Text:=CStr(arr(lngRow, lngCol)) Else appWD.Selection.typetext Text:=CStr(arr(lngRow, lngCol)) & vbTab End If Next lngCol If lngRow <> UBound(arr(), 1) Then appWD.Selection.TypeParagraph End If Next lngRow appWD.Selection.WholeStory appWD.Selection.ConvertToTable Separator:=1, NumColumns:=UBound(arr(), 2), _ NumRows:=UBound(arr(), 1), AutoFitBehavior:=0 With appWD.Selection.Tables(1) .Style = "Table Grid" .ApplyStyleHeadingRows = True .ApplyStyleLastRow = True .ApplyStyleFirstColumn = True .ApplyStyleLastColumn = True End With appWD.Selection.EndKey Unit:=6 appWD.Visible = True Set appWD = Nothing Application.ScreenUpdating = True End Sub ودا أيضا Sub CreateRapport() Dim wdApp As Object Dim wd As Object On Error Resume Next Set wdApp = GetObject(, "Word.Application") If Err.Number <> 0 Then Set wdApp = CreateObject("Word.Application") End If On Error GoTo 0 Set wd = wdApp.Documents.Add wdApp.Visible = True Sheets("Rapport").Activate Set Rng = ThisWorkbook.ActiveSheet.Range("A1:E76") Rng.Copy With wd.Range .Collapse Direction:=0 'Slutet av dokumentet .InsertParagraphAfter 'La"gg till rad .Collapse Direction:=0 'Slutet av dokumentet .PasteSpecial False, False, True 'Pasta som Enhanced Metafile End With End Sub

تفضل أخى لعله المطلوب Sub CopyCommentsToWord() 'Update 20140325 Dim xComment As Comment Dim wApp As Object On Error Resume Next Set wApp = GetObject(, "Word.Application") If Err.Number <> 0 Then Err.Clear Set wApp = CreateObject("Word.Application") End If wApp.Visible = True wApp.Documents.Add DocumentType:=0 For Each xComment In Application.ActiveSheet.Comments wApp.Selection.TypeText xComment.Parent.Address & vbTab & xComment.Text wApp.Selection.TypeParagraph Next Set wApp = Nothing End Sub

كود معاينة للطباعة Print Preview.rar

يسعدنى ويشرفنى مرورك الكريم لمشاركة لى أخى الفاضل أ / محمد صالح شكرا لحضرتك

السادة الأفاضل أحبائى الأعزاء أعضاء المنتدى الكرام مرفق شيت يقوم بتصفح الإنترنت من خلاله يا رب ينال إعجابكم Web Browser In The Internet.rar

السادة الأفاضل أعضاء المنتدى الكرام أقدم لكم اليوم شيت إكسيل يقوم بفتح البريد الإلكترونى منه أوتوماتيك فقط أكتب البريد الإلكترونى والباسوورد ثم إدخل Website Log-In Automation.rar

تفضل أخى الفاضل يا رب يكون المطلوب يوضع الكود داخل module Sub CreatePowerPoint() 'Add a reference to the Microsoft PowerPoint Library by: '1. Go to Tools in the VBA menu '2. Click on Reference '3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay 'First we declare the variables we will be using Dim newPowerPoint As PowerPoint.Application Dim activeSlide As PowerPoint.Slide Dim cht As Excel.ChartObject 'Look for existing instance On Error Resume Next Set newPowerPoint = GetObject(, "PowerPoint.Application") On Error GoTo 0 'Let's create a new PowerPoint If newPowerPoint Is Nothing Then Set newPowerPoint = New PowerPoint.Application End If 'Make a presentation in PowerPoint If newPowerPoint.Presentations.Count = 0 Then newPowerPoint.Presentations.Add End If 'Show the PowerPoint newPowerPoint.Visible = True 'Loop through each chart in the Excel worksheet and paste them into the PowerPoint For Each cht In ActiveSheet.ChartObjects 'Add a new slide where we will paste the chart newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count) 'Copy the chart and paste it into the PowerPoint as a Metafile Picture cht.Select ActiveChart.ChartArea.Copy activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select 'Set the title of the slide the same as the title of the chart activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text 'Adjust the positioning of the Chart on Powerpoint Slide newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15 newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125 activeSlide.Shapes(2).Width = 200 activeSlide.Shapes(2).Left = 505 'If the chart is the "US" consumption chart, then enter the appropriate comments If InStr(activeSlide.Shapes(1).TextFrame.TextRange.Text, "US") Then activeSlide.Shapes(2).TextFrame.TextRange.Text = Range("J7").Value & vbNewLine activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J8").Value & vbNewLine) 'Else if the chart is the "Renewable" consumption chart, then enter the appropriate comments ElseIf InStr(activeSlide.Shapes(1).TextFrame.TextRange.Text, "Renewable") Then activeSlide.Shapes(2).TextFrame.TextRange.Text = Range("J27").Value & vbNewLine activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J28").Value & vbNewLine) activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J29").Value & vbNewLine) End If 'Now let's change the font size of the callouts box activeSlide.Shapes(2).TextFrame.TextRange.Font.Size = 16 Next AppActivate ("Microsoft PowerPoint") Set activeSlide = Nothing Set newPowerPoint = Nothing End Sub وجرب دا أيضا يقوم بتحويل جميع الشيتات إلى Slide داخل البور بوينت Sub WorkbooktoPowerPoint() 'Step 1: Declare your variables Dim pp As Object Dim PPPres As Object Dim PPSlide As Object Dim xlwksht As Worksheet Dim MyRange As String Dim MyTitle As String 'Step 2: Open PowerPoint, add a new presentation and make visible Set pp = CreateObject("PowerPoint.Application") Set PPPres = pp.Presentations.Add pp.Visible = True 'Step 3: Set the ranges for your data and title MyRange = "B2:BH40" '<<<Change this range 'Step 4: Start the loop through each worksheet For Each xlwksht In ActiveWorkbook.Worksheets xlwksht.Select Application.Wait (Now + TimeValue("0:00:1")) 'Step 5: Copy the range as picture xlwksht.Range(MyRange).CopyPicture _ Appearance:=xlScreen, Format:=xlPicture 'Step 6: Count slides and add new blank slide as next available slide number '(the number 12 represents the enumeration for a Blank Slide) SlideCount = PPPres.Slides.Count Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12) PPSlide.Select 'Step 7: Paste the picture and adjust its position PPSlide.Shapes.Paste.Select pp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True pp.ActiveWindow.Selection.ShapeRange.Top = 1 pp.ActiveWindow.Selection.ShapeRange.Left = 1 pp.ActiveWindow.Selection.ShapeRange.Width = 700 'Step 8: Add the title to the slide then move to next worksheet Next xlwksht 'Step 9: Memory Cleanup pp.Activate Set PPSlide = Nothing Set PPPres = Nothing Set pp = Nothing End Sub

تفضل أخى الفاضل يا رب يكون المطلوب يوضع الكود داخل module Sub CreatePowerPoint() 'Add a reference to the Microsoft PowerPoint Library by: '1. Go to Tools in the VBA menu '2. Click on Reference '3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay 'First we declare the variables we will be using Dim newPowerPoint As PowerPoint.Application Dim activeSlide As PowerPoint.Slide Dim cht As Excel.ChartObject 'Look for existing instance On Error Resume Next Set newPowerPoint = GetObject(, "PowerPoint.Application") On Error GoTo 0 'Let's create a new PowerPoint If newPowerPoint Is Nothing Then Set newPowerPoint = New PowerPoint.Application End If 'Make a presentation in PowerPoint If newPowerPoint.Presentations.Count = 0 Then newPowerPoint.Presentations.Add End If 'Show the PowerPoint newPowerPoint.Visible = True 'Loop through each chart in the Excel worksheet and paste them into the PowerPoint For Each cht In ActiveSheet.ChartObjects 'Add a new slide where we will paste the chart newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count) 'Copy the chart and paste it into the PowerPoint as a Metafile Picture cht.Select ActiveChart.ChartArea.Copy activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select 'Set the title of the slide the same as the title of the chart activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text 'Adjust the positioning of the Chart on Powerpoint Slide newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15 newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125 activeSlide.Shapes(2).Width = 200 activeSlide.Shapes(2).Left = 505 'If the chart is the "US" consumption chart, then enter the appropriate comments If InStr(activeSlide.Shapes(1).TextFrame.TextRange.Text, "US") Then activeSlide.Shapes(2).TextFrame.TextRange.Text = Range("J7").Value & vbNewLine activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J8").Value & vbNewLine) 'Else if the chart is the "Renewable" consumption chart, then enter the appropriate comments ElseIf InStr(activeSlide.Shapes(1).TextFrame.TextRange.Text, "Renewable") Then activeSlide.Shapes(2).TextFrame.TextRange.Text = Range("J27").Value & vbNewLine activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J28").Value & vbNewLine) activeSlide.Shapes(2).TextFrame.TextRange.InsertAfter (Range("J29").Value & vbNewLine) End If 'Now let's change the font size of the callouts box activeSlide.Shapes(2).TextFrame.TextRange.Font.Size = 16 Next AppActivate ("Microsoft PowerPoint") Set activeSlide = Nothing Set newPowerPoint = Nothing End Sub

شكرا لك n_tareq

رابعا : كود لعمل إرتباطات شعبية تلقائيا بأسماء الشيتات المدونة من خلالك بشيت 1 يمكنك عمل بداية مسمى الشيتات كيفما تحب عن طريق رقم 5 وتغييرة كما تشاء وتذويد أسماء الشيتات من خلال رقم 9 أيضا كما تشاء من خلال هذا السطر الموجود داخل الكود iCntr = 5 ' worksheets names starts from 9th row Create Sheets and Hyperlinks.rar

السادة الأفاضل إخوانى وأحبائى الأعزاء أعضاء المنتدى الكرام أتقدم لكم اليوم بمجموعة أكواد مرفقة بأمثلة للفائدة أسألكم الدعاء أولا : كود لعمل ListBox . ثانيا : كود لتحويل صفحة الإكسيل بما فيها إلى بور يوينت . ثالثا : : كود كتابة نص داخل جدول وقرائته داخل جدول أخر . ListBox.rar ExportTo PowerPoint.rar Writing to Text File and Reading From Text File.rar

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

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

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