Использование данных Excel для создания подписей Word Do c в VBA - PullRequest
Новая
       61

Использование данных Excel для создания подписей Word Do c в VBA

0 голосов
/ 22 января 2020

Я пытаюсь связать отчет документа Word с базой данных Excel с помощью VBA. Я вставил в свой документ различные элементы управления текстовым полем ActiveX. Я вручную ввожу каждое из этих текстовых полей с уникальным кодом («Код»). Другие элементы управления текстового поля будут автоматически заполняться на основе связанных данных в базе данных Excel. Соответствующим фактором будет «Код».

Когда я запускаю следующий код, я получаю

Ошибка времени выполнения 13 «Несоответствие типов»

в строке 16 (If cell.Value...) , У меня нет большого опыта работы с VBA, но я видел много примеров, показывающих, что команда Value должна быть привязана к объекту Range. Спасибо за вашу помощь. 

Private Sub CommandButton1_Click()

Dim objExcel As New Excel.Application
Dim exWb As Excel.Workbook
Dim b As Excel.Range
Dim c As Excel.Range
Dim r As Excel.Range
Dim cell As Excel.Range

'Set variables
Set exWb = objExcel.Workbooks.Open("C:\Documents\Book.xlsx")
Set b = exWb.Sheets("Sheet1").Range("B:B")
Set c = exWb.Sheets("Sheet1").Range("C:C")
Set r = exWb.Sheets("Sheet1").Rows
Set cell = exWb.Sheets("Sheet1").Range("A1:Z1000")

For Each r In c
    If cell.Value = ThisDocument.TextBox1.Value Then
        ThisDocument.TextBox2.Value = b.Value
   End If
Next r

exWb.Close
Set exWb = Nothing

End Sub

1 Ответ

1 голос
/ 22 января 2020

Вы можете попробовать что-то вроде этого: 

Private Sub CommandButton1_Click()

    Dim objExcel As New Excel.Application
    Dim exWb As Excel.Workbook
    Dim rng As Excel.Range, m, rw As Excel.Range

    'Set variables
    Set exWb = objExcel.Workbooks.Open("C:\Documents\Book.xlsx")
    Set rng = exWb.Sheets("Sheet1").Range("A1:Z1000")

    'Here we're looking for a match in ColC...
    '  change 3 to any other column you want to match on
    m = objExcel.Match(ThisDocument.TextBox1.Value, rng.Columns(3), 0)

    If Not IsError(m) Then

        'got a match - fetch the other values from that row
        Set rw = rng.Rows(m) '<< get the matching row as a Range
        ThisDocument.TextBox2.Value = rw.Cells(1).Value 'value from colA
        ThisDocument.TextBox3.Value = rw.Cells(2).Value 'value from colB

    Else
        'no match - clear the other textboxes?
        MsgBox "No match found!"
        ThisDocument.TextBox2.Value = ""
        ThisDocument.TextBox3.Value = ""
    End If

    exWb.Close False 'no changes saved
    Set exWb = Nothing

End Sub
...