Consulting

Page 2 of 2 FirstFirst 1 2
Results 21 to 22 of 22

Thread: Macro for replacing EXCEL data into WORD

  1. #21
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    3,894
    Location
    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
    [MS MVP - Word]

  2. #22
    Microsoft Word MVP 2003-2009 VBAX Guru gmaxey's Avatar
    Joined
    Sep 2005
    Posts
    3,063
    Location
    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
    Greg

    Visit my website: http://gregmaxey.com

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •