Macro for replacing EXCEL data into WORD

[gmaxey]

Paul,

I agree! I don't like Sticky posts either (of any type). This is another good one for ADODB. I've not tried very hard to find a solution, because for my own use it has not been a problem. However if you go digging into this topic you might be compelled to conjure up a method to prevent trying to connect with a database that is not accessible because it is in use. You will see the potential problem if you have your Excel file open with the cursor in the formula bar and ignore the note to cancel.

Option Explicit
Sub BulkFindReplace()
Dim arrList
Dim lngIndex As Long
Dim strWBName As String
Dim oRng As Range
  'Get the list of terms to find and replace.
  strWBName = ThisDocument.Path & "\Word List.xlsx" 'Change to suit path and file name.
  If Dir(strWBName) = "" Then
    MsgBox "Cannot find the designated workbook: " & strWBName, vbExclamation
    Exit Sub
  End If
  If IsFileLocked(strWBName) Then
    If MsgBox("The data file is open in Excel." & vbCr + vbCr _
         & "While the Excel file can be open while accessing data, " _
         & "the underlying database cannot be in transition " _
         & "e.g., the cursor in the formula bar." & vbCr + vbCr _
         & "When in transistion a connection to the data cannot be made." & vbCr + vbCr _
         & "Recommend you cancel, then save and close the Excel file and try again." & vbCr + vbCr _
         & "Do you want to cancel?", vbQuestion + vbYesNo, "IMPORTANT USER NOTIFICATION") = vbYes Then
         Exit Sub
    End If
  End If
  arrList = fcnExcelDataToArray(strWBName)
  Application.ScreenUpdating = True
  If IsArray(arrList) Then
  For lngIndex = 0 To UBound(arrList, 2)
    Set oRng = ActiveDocument.Range
    With oRng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchWholeWord = True
      .MatchCase = True
      .Wrap = wdFindStop
      .Text = arrList(0, lngIndex)
      'For automatic replacement unstet the following two lines and stet out all between While and Wend _
       that follows
      '.Replacement.Text = arrList(1, lngIndex)
      '.Execute Replace:=wdReplaceAll
      'For user prompt and manual replacement, stet out previous two lines and use:
      While .Execute
        With oRng
          .Duplicate.Select
          Select Case MsgBox("Replace this instance of: " & arrList(0, lngIndex) _
              & vbCr & "with: " & arrList(1, lngIndex), vbYesNoCancel)
            Case vbYes: .Text = arrList(1, lngIndex)
            Case vbCancel: Exit Sub
          End Select
          .Collapse wdCollapseEnd
        End With
      Wend
    End With
  Next
  Else
    MsgBox "A connection was not available to the Excel file."
  End If
  Application.ScreenUpdating = True
lbl_Exit:
  Exit Sub
End Sub
 
Private Function fcnExcelDataToArray(strWorkbook As String, _
                                     Optional strRange As String = "Sheet1", _
                                     Optional bIsSheet As Boolean = True, _
                                     Optional bHeaderRow As Boolean = True) As Variant
'Default parameters include "Sheet1" as the named sheet, range of the full named sheet and a header row is used.
Dim oRS As Object, oConn As Object
Dim lngRows As Long
Dim strHeaderYES_NO As String
  strHeaderYES_NO = "YES"
  If Not bHeaderRow Then strHeaderYES_NO = "NO"
  If bIsSheet Then strRange = strRange & "$]" Else strRange = strRange & "]"
  Set oConn = CreateObject("ADODB.Connection")
  oConn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & strWorkbook & ";" & _
        "Extended Properties=""Excel 12.0 Xml;HDR=" & strHeaderYES_NO & """;"
  If oConn.State = 0 Then
    oConn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.15.0;" & _
        "Data Source=" & strWorkbook & ";" & _
        "Extended Properties=""Excel 12.0 Xml;HDR=" & strHeaderYES_NO & """;"
  End If
  If oConn.State = 1 Then
    Set oRS = CreateObject("ADODB.Recordset")
    oRS.Open "SELECT * FROM [" & strRange, oConn, 2, 1
    With oRS
      .MoveLast
      lngRows = .RecordCount
      .MoveFirst
    End With
    fcnExcelDataToArray = oRS.GetRows(lngRows)
  Else
    fcnExcelDataToArray = "~~NO CONNECTION AVAILABLE~~"
  End If
lbl_Exit:
  If oConn.State = 1 Then
    oConn.Close
    If oRS.State = 1 Then oRS.Close
    Set oRS = Nothing
  End If
  Set oConn = Nothing
  Exit Function
End Function
Function IsFileLocked(strFileName As String) As Boolean
    On Error Resume Next
    Open strFileName For Binary Access Read Write Lock Read Write As #1
    Close #1
    IsFileLocked = Err.Number
    Err.Clear
End Function