# Copy content from word to excel using exel VBA



## ee97zzg (Mar 5, 2019)

Hi VBA Gurus,

I would like to copy text or paragraphs between two headers from docx to xlsx file.

1. The VBA script needs to run from excel using Early Binding technique (referencing to Object Libary)
2. The two headers will always remain the same and will never change.
3. The code needs to copy to Thisworkbook which is the macro workbook.

Example:

COMPANY A (This is header 1 and the name of the header will never change)

Some text........(so the code needs to copy this)

COMPANY B (This is header 2 and the name of the hader will never change)

The aim is to copy the content into Powerpoint on specific slides and shape. I have not seen a way of copying content directly from word to powerpoint unless anyone here knows using Excel VBA.

Looking forward to hearing from you


----------



## Trevor G (Mar 5, 2019)

You could setup a couple of bookmarks in the Word document and then use the following code to copy between the bookmarks and then paste  into excel. The example is using the reference object to Word though but it gives you a start point. Bookmark names are Start and End.



> Sub CopyTextBetweenBookmarks2Bookmarks()
> Dim wrdApp As Word.Application
> Set wrdApp = CreateObject("Word.Application")
> Set rngStart = ActiveDocument.Bookmarks("Start").Range
> ...


----------



## ee97zzg (Mar 5, 2019)

Thanks Trevor unfortunatley I am unable to change anything on the word document.

Is there any other way.


----------



## Macropod (Mar 5, 2019)

Try something based on:

```
Sub Demo()
'Note: A reference to the Word and PowerPoint libraries must be set, via Tools|References
Dim wdApp As New Word.Application, wdDoc As Word.Document, wdRng As Word.Range
Dim ppApp As New PowerPoint.Application, ppPrs As PowerPoint.Presentation
Const StrDocNm As String = "Full document path & name"
Const StrPrsNm As String = "Full presentation path & name"
If Dir(StrDocNm) = "" Then Exit Sub: If Dir(StrPrsNm) = "" Then Exit Sub
With wdApp
  .Visible = False
  Set wdDoc = .Documents.Open(FileName:=StrDocNm, ReadOnly:=True, AddToRecentfiles:=False)
  With wdDoc
    With .Range
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "Company A"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Execute
      End With
      If .Find.Found = True Then
        Set wdRng = .Paragraphs(1).Range
        Set wdRng = wdRng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
        wdRng.Start = wdRng.Paragraphs.First.Range.End
        wdRng.Copy
      End If
    End With
    'close
    .Close SaveChanges:=False
  End With
  .Quit
End With
With ppApp
  .Visible = True
  Set ppPrs = .Presentations.Open(FileName:=StrPrsNm, ReadOnly:=False)
  With ppPrs
    .Slides(1).Shapes(1).TextFrame.TextRange.Paste
  End With
  .Activate
End With
Set wdRng = Nothing: Set wdDoc = Nothing: Set ppApp = Nothing
Set ppPrs = Nothing: Set wdApp = Nothing
End Sub
```


----------



## ee97zzg (Mar 7, 2019)

Finally figured out another way see below

Sub CopyTextBetweenWords()
' Purpose: copy and pastes text between two words using Excel VBA from Word to Powerpoint.
' the words "COMPANY A" and "COMPANY B" if they both appear.
    'Declare powerpoint variables
    Dim ppApp As PowerPoint.Application
    Dim ppPres As PowerPoint.Presentation
    Dim ppSlide As PowerPoint.Slide
    Dim ppShape As PowerPoint.Shape
    Dim tbl As PowerPoint.Table
    Dim StrPrsNm As String
    Set ppApp = New PowerPoint.Application

    'Declare word variables
    Dim wdApp As Word.Application
    Dim wDoc As Word.Document
    Dim wRng As Word.Range
    Dim rng1 As Word.Range
    Dim rng2 As Word.Range
    Dim strTheText As String
    Set wdApp = New Word.Application
    wdApp.Visible = True

    Const StrDocNm As String = "C:\Desktop\Test\WORD_File.docx"
    Const StrPrsNm As String = "C:\Desktop\Test\POWERPOINT_File.pptx"

    Set wDoc = wdApp.Documents.Open(Filename:=StrDocNm, ReadOnly:=True, AddToRecentfiles:=False)

    Set rng1 = wDoc.Range
    If rng1.Find.Execute(FindText:="COMPANY A") Then
        Set rng2 = wDoc.Range(rng1.End, wDoc.Range.End)
        If rng2.Find.Execute(FindText:="COMPANY B") Then
            Set wRng = wDoc.Range(rng1.End, rng2.Start)

            wRng.Copy

            ppApp.Visible = msoTrue
            Set ppPres = ppApp.Presentations.Open(Filename:=StrPrsNm, ReadOnly:=False)

            Set tbl = ppPres.Slides(3).Shapes.Range("Slide3Shape3").Table 'the ppt shape can be TextBox or Table change data type depending on the shape type
            tbl.Cell(2, 1).Shape.TextFrame.TextRange.Text = wRng.Text
        End If
    End If
End Sub


----------



## Macropod (Mar 7, 2019)

Here's a better way. With the code I posted, change:

```
With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "Company A"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Execute
      End With
      If .Find.Found = True Then
        Set wdRng = .Paragraphs(1).Range
        Set wdRng = wdRng.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
        wdRng.Start = wdRng.Paragraphs.First.Range.End
        wdRng.Copy
      End If
```
to:

```
With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "Company A*Company B"
        .Replacement.Text = ""
        .Forward = True
        .MatchWildcards = True
        .Wrap = wdFindStop
        .Execute
      End With
      If .Find.Found = True Then
        Set wdRng = .Duplicate
        With wdRng
          .Start = .Paragraphs.First.Range.End
          .End = .Paragraphs.Last.Range.Start
        End With
        wdRng.Copy
      End If
    End With
```
Naturally, you'll need to update the other references to point to the correct files, etc. Note, too, that the 'Company A' & 'Company B' strings are case-sensitive with this approach.

*PS:* When posting code, please use the code tags, indicated by the # button on the posting menu. Without them, your code loses much of whatever structure it had.


----------

