أكواد VBA مفيدة

[Yasser Fathi Albanna]

السادة الأفاضل إخوانى وأحبائى الأعزاء أعضاء المنتدى الكرام

أتقدم لكم اليوم بمجموعة أكواد مرفقة بأمثلة للفائدة

أسألكم الدعاء

 

أولا : كود لعمل  ListBox .

ثانيا : كود لتحويل صفحة الإكسيل بما فيها إلى بور يوينت .

ثالثا : : كود كتابة نص داخل جدول وقرائته داخل جدول أخر .

ListBox.rar

ExportTo PowerPoint.rar

Writing to Text File and Reading From Text File.rar

[Yasser Fathi Albanna]

رابعا : كود لعمل إرتباطات شعبية تلقائيا بأسماء الشيتات المدونة من خلالك بشيت 1

يمكنك عمل بداية مسمى الشيتات كيفما تحب عن طريق رقم 5 وتغييرة كما تشاء

وتذويد أسماء الشيتات من خلال رقم 9 أيضا كما تشاء

من خلال هذا السطر الموجود داخل الكود

 iCntr = 5 ' worksheets names starts from 9th row

Create Sheets and Hyperlinks.rar

[طارق_نادر]

جهودك مشكورة اكواد جميلة ومفيدة

[Yasser Fathi Albanna]

جهودك مشكورة اكواد جميلة ومفيدة

شكرا لك n_tareq

[وليد زقزوق]

الاخ

Eng : Yasser Fathi Albanna

يا حبذا لو كود التحويل الي بور بوينت لا يعتمد علي رنج بعينع في الكود وانما يعتمد علي الرنج النشط اي يصدر الرنج الذي احدده انا

[Yasser Fathi Albanna]

الاخ

Eng : Yasser Fathi Albanna

يا حبذا لو كود التحويل الي بور بوينت لا يعتمد علي رنج بعينع في الكود وانما يعتمد علي الرنج النشط اي يصدر الرنج الذي احدده انا

تفضل أخى الفاضل يا رب يكون المطلوب

يوضع الكود داخل 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

[Yasser Fathi Albanna]

 

الاخ

Eng : Yasser Fathi Albanna

يا حبذا لو كود التحويل الي بور بوينت لا يعتمد علي رنج بعينع في الكود وانما يعتمد علي الرنج النشط اي يصدر الرنج الذي احدده انا

تفضل أخى الفاضل يا رب يكون المطلوب

يوضع الكود داخل 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

[saaad 213]

السلام عليكم

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

تم تعديل يناير 30, 2015 بواسطه saaad1

[Yasser Fathi Albanna]

كود معاينة للطباعة

Print Preview.rar

[Yasser Fathi Albanna]

السلام عليكم

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

تفضل أخى لعله المطلوب

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

[Yasser Fathi Albanna]

 

السلام عليكم

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

تفضل أخى لعله المطلوب

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

[احمد العدوى]

م / ياسر

بارك الله فيك

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

[احمد العدوى]

شكرا م /ياسر

تم نسخ محتويات الاكسيل الى الوورد

[Yasser Fathi Albanna]

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

[myyasser]

بارك الله فيك   واطال في عمرك وحسن عملك

 

[ابو خالد التقني]

شكرا 

 

وجزالك الله خيرا

[Yasser Fathi Albanna]

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

[وليد زقزوق]

الاخ

Eng : Yasser Fathi Albanna

بيديني الخظا ده

[ياسر فاروق]

م / ياسر فتحى البنا

السلام عليكم ورحمة الله وبركاته

برجاء المساعدة

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

[ياسر فاروق]

م/ياسر

برجاء المساعده

مرفق ملف اكسيل وأريد كود

- تجميع كل صفحة فى أخر الصفحة

- نقل مجموع الصفحة الى الصفحة التجميعية

- ثم الى صفحة الاجماليات

هل من الممكن أن يكون التجميع ونقل المجموع يتم عن طريق الجمل المكتوبة وليست أرقام الاعمدة لانها متغيرة

وشكرا

BOQ02.xlsx