Copy content from word to excel using exel VBA

[ee97zzg]

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]

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
Set rngEnd = ActiveDocument.Bookmarks("End").Range
ActiveDocument.Range(rngStart.Start, rngEnd.End).Copy
Range("A10").PasteSpecial

End Sub

 

[ee97zzg]

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

Is there any other way.

 

[Macropod]

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]

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]

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.