MS Word macro to find text from Excel list in Word doc, then copy and paste chunks from Word doc to new Word doc

[amaneta67]

Hello!

This is a doozy, so I'm not holding my breath, but I believe in you!

I have a list of item IDs (e.g., SCBW1460, all follow the pattern of 4 letters then 4 numbers) in an Excel sheet. This list currently has 200 entries, all in column A, nothing else in the sheet. A1 has a header in it, "List". This list may expand or contract, so I don't want the macro to be limited to just 200 items.

I also have a Word document that contains exam questions, options, and answers. This document is 1873 pages long, and it contains the 200 items listed in the Excel file, along with 1000s of others, in no particular order. I want to pull out these 200 items and put ONLY them in a new Word doc. In this 1873 page Word doc, every exam item "chunk" begins with "Item Stem: ", with the item ID after it, so, for example, "Item Stem: SCBW1460". This is always its own paragraph, no other text is in that line. After this line, many things can happen, but the exam item always ends with "Answer: " then the correct answer as a single letter, so, for example, "Answer: C". Again, this is the only data in that paragraph/line.

I'm wondering if a macro can be written that looks in the Excel list for the first item ID, switches to the 1873 page Word doc, finds the item ID, selects the paragraph/line with that item ID, then goes down until it finds the first "Answer: " paragraph/line, selects it and all the text between, copies the selected text, switches to another Word doc (let's say it's already existing and is empty, called "subset.docx"), pastes the selection, adds 2 manual line returns so the items are clearly separated, then starts over and looks at the next item ID in the Excel file, finds it in the 1873 page Word doc, etc.

Each item ID is unique, so no issues there.

And, if this can be done, I'm sure there's a better way than what I describe above, so I'm open to other ideas.

Here's a sample of a simple Word item:

Item Stem: SCBD9100
How hot is the sun?

Option Set: XCAU8464
(A) Pretty cool
(B) Tepid
(C) Warmish
(D) Hot
(F) Scorching

Answer: F

Anything, however, can be between "Item Stem:" and "Answer:" though, like tables, lots of paragraphs, etc.

Thanks in advance for your time and effort!

 

[Macropod]

Fairly easily done. Try:

Sub CopyQuestions()
Application.ScreenUpdating = False
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, xlFList As String
Dim wdDocSrc As Document, wdDocTgt As Document, lRow As Long, i As Long
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\DataList.xlsx"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
On Error Resume Next
'Start Excel
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel.", vbExclamation
  Exit Sub
End If
On Error GoTo 0
With xlApp
  'Hide our Excel session
  .Visible = False
  ' The file is available, so open it.
  Set xlWkBk = .Workbooks.Open(StrWkBkNm, False, True)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    .Quit: Set xlApp = Nothing: Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk
    With .Worksheets("Sheet1")
      ' Find the last-used row in column A.
      lRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
      ' Capture the F/R data.
      For i = 1 To lRow
        ' Skip over empty fields to preserve the underlying cell contents.
        If Trim(.Range("A" & i)) <> vbNullString Then xlFList = xlFList & "|" & Trim(.Range("A" & i))
      Next
    End With
    .Close False
  End With
  .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Exit if there are no data
If xlFList = "" Then Exit Sub
Set wdDocSrc = ActiveDocument: Set wdDocTgt = Documents.Add
'Process each word from the F/R List
For i = 1 To UBound(Split(xlFList, "|"))
  With wdDocSrc.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchWildcards = True
      .Wrap = wdFindContinue
      .Replacement.Text = ""
      .Text = "[!^13]@" & Split(xlFList, "|")(i) & "*Answer[!^13]@^13"
      .Execute
    End With
    If .Find.Found = True Then
      wdDocTgt.Range.Characters.Last.FormattedText = .FormattedText
      wdDocTgt.Range.InsertAfter vbCr & vbCr & vbCr
    End If
  End With
Next
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub

The above code can be run from any Word document, but expects the active document to be your 1873 page one. The code assumes the Excel workbook is named 'DataList.xlsx' and is located in your Documents folder.

 

[amaneta67]

Oh! So beautiful! I will test this and get back to you. THANK YOU so much!!!

 

[amaneta67]

Fairly easily done. Try:

Sub CopyQuestions()
Application.ScreenUpdating = False
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, xlFList As String
Dim wdDocSrc As Document, wdDocTgt As Document, lRow As Long, i As Long
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\DataList.xlsx"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
On Error Resume Next
'Start Excel
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel.", vbExclamation
  Exit Sub
End If
On Error GoTo 0
With xlApp
  'Hide our Excel session
  .Visible = False
  ' The file is available, so open it.
  Set xlWkBk = .Workbooks.Open(StrWkBkNm, False, True)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    .Quit: Set xlApp = Nothing: Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk
    With .Worksheets("Sheet1")
      ' Find the last-used row in column A.
      lRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
      ' Capture the F/R data.
      For i = 1 To lRow
        ' Skip over empty fields to preserve the underlying cell contents.
        If Trim(.Range("A" & i)) <> vbNullString Then xlFList = xlFList & "|" & Trim(.Range("A" & i))
      Next
    End With
    .Close False
  End With
  .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Exit if there are no data
If xlFList = "" Then Exit Sub
Set wdDocSrc = ActiveDocument: Set wdDocTgt = Documents.Add
'Process each word from the F/R List
For i = 1 To UBound(Split(xlFList, "|"))
  With wdDocSrc.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchWildcards = True
      .Wrap = wdFindContinue
      .Replacement.Text = ""
      .Text = "[!^13]@" & Split(xlFList, "|")(i) & "*Answer[!^13]@^13"
      .Execute
    End With
    If .Find.Found = True Then
      wdDocTgt.Range.Characters.Last.FormattedText = .FormattedText
      wdDocTgt.Range.InsertAfter vbCr & vbCr & vbCr
    End If
  End With
Next
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub

The above code can be run from any Word document, but expects the active document to be your 1873 page one. The code assumes the Excel workbook is named 'DataList.xlsx' and is located in your Documents folder.

Hi Macropod:

This works! It's amazing! Thank you so much!