Microsoft Office Forums - View Single Post - Excel to Word data import based on UserForm entry

gmayor · 05-07-2017, 08:59 PM

Frankly I wouldn't do it that way as it is slow and cumbersome. The following functions will read the named worksheet into an array then search the first column of the array for the input value (here "The value to find") and outputs the corresponding value from column 6 to the bookmark (here "bookmarkname"). If the value is not found the bookmark is cleared.

It is assumed that the named worksheet has at least six columns, that there is a header row on the first row and there are no empty columns. The sheet name is case sensitive.

If you need to loop through several worksheets, then all the sheets searched must match the criteria above. The array function takes no prisoners.

Macro1 simply shows how to call the functions. You can call the functions from your form using the appropriate values.

Code:

Option Explicit
Const strWorkbook As String = "U:\VBA Word Automation\Excel Test Sheet.xlsx"
Const strSheet As String = "Sheet1"        'The name of the worksheet

Sub Macro1()
'look for the value in the first column and return the value in the sixth column
Dim strResult As String
    strResult = GetValue("The value to find", 6)
    FillBM "bookmarkname", strResult 'fill the named bookmark with the value
lbl_Exit:
    Exit Sub
End Sub

Private Function GetValue(strKey As String, lngColumn As Long) As String
'Graham Mayor - http://www.gmayor.com - Last updated - 08 May 2017
Dim Arr() As Variant
Dim iCols As Long
Dim strValue As String
Dim strID As String
    Arr = xlFillArray(strWorkbook, strSheet)
    For iCols = 0 To UBound(Arr, 2)
        strID = Arr(0, iCols)    'The first column
        strValue = Arr(lngColumn - 1, iCols)
        If strID = strKey Then
            GetValue = strValue
            Exit For
        End If
    Next iCols
lbl_Exit:
    Exit Function
End Function

Private Function xlFillArray(strWorkbook As String, _
                             strRange As String) As Variant
'Graham Mayor - http://www.gmayor.com - Last updated - 08 May 2017

Dim RS As Object
Dim CN As Object
Dim iRows As Long

    strRange = strRange & "$]"
    Set CN = CreateObject("ADODB.Connection")
    
    CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                              "Data Source=" & strWorkbook & ";" & _
                              "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

    Set RS = CreateObject("ADODB.Recordset")
    RS.Open "SELECT * FROM [" & strRange, CN, 2, 1

    With RS
        .MoveLast
        iRows = .RecordCount
        .MoveFirst
    End With
    xlFillArray = RS.GetRows(iRows)
    If RS.State = 1 Then RS.Close
    Set RS = Nothing
    If CN.State = 1 Then CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function

Private Sub FillBM(strBMName As String, strValue As String)
'Graham Mayor - http://www.gmayor.com
Dim oRng As Range
    With ActiveDocument
        On Error GoTo lbl_Exit
        Set oRng = .Bookmarks(strBMName).Range
        oRng.Text = strValue
        oRng.Bookmarks.Add strBMName
    End With
lbl_Exit:
    Set oRng = Nothing
    Exit Sub
End Sub