I'm not inclined to go creating 'sticky' threads for individual topics that get resurrected periodically. A knowledgebase article might be more appropriate.
Printable View
I'm not inclined to go creating 'sticky' threads for individual topics that get resurrected periodically. A knowledgebase article might be more appropriate.
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.
Code: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