I'm not inclined to go creating 'sticky' threads for individual topics that get resurrected periodically. A knowledgebase article might be more appropriate.
I'm not inclined to go creating 'sticky' threads for individual topics that get resurrected periodically. A knowledgebase article might be more appropriate.
Cheers
Paul Edstein
[Fmr MS MVP - Word]
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