匹配数据子集

Question

我正在用 VBA 中的 Excel 数据子集填充 ActiveX 控件标签。 我的代码以前适用于整个 Excel 工作簿，但是一旦我将代码更改为仅引用数据的一个子集，就会输入不正确的数据。

这是示例数据的快照。 在我的代码中，第 6 列 = CY，第 7 列 = FY。 该代码当前正在使用第 6 列和第 7 列的标题而不是“活动”或“合并”项目的值填充我的标签。

如前所述，我没有收到任何错误消息，但没有将正确的数据添加到我的 ActiveX 标签中。 仅供参考...在第 31 行Code1是 ActiveX 标签的名称。

Private Sub CommandButton1_Click()

    Dim objExcel As Excel.Application
    Dim exWB As Excel.Workbook
    Dim rng As Excel.Range, m, rw As Excel.Range
    Dim num, TableNo, seq As Integer
    Dim ctl As MSForms.Label
    Dim ils As Word.InlineShape
    Dim rngrow As Excel.Range
    Dim active As Excel.Range

    Set objExcel = New Excel.Application
    TableNo = ActiveDocument.Tables.Count
    num = 3
    seq = 1

Set exWB = objExcel.Workbooks.Open("O:\Documents\"Database.csv")
Set rng = exWB.Sheets("Sheet1").Cells

''''Select active projects as subset
    For Each rngrow In rng.Range("A1:L144")
     If rngrow.Columns(8).value = "Active" Or rngrow.Columns(8).value = "Merged" Then
            If active Is Nothing Then
                Set active = rngrow
            Else
                Set active = Union(active, rngrow)
            End If
        End If
    Next rngrow

    m = objExcel.Match(ActiveDocument.Code1.Caption, active.Columns(3), 0)

'' Now, create all ActiveX FY labels and populate with FY Use
Do
    Set ils = ActiveDocument.Tables(num).cell(6, 2).Range.InlineShapes.AddOLEControl(ClassType:="Forms.Label.1")
    Set ctl = ils.OLEFormat.Object
    ctl.Name = "FY" & seq
    If Not IsError(m) Then
    Set rw = rng.Rows(m)
    ctl.Caption = rw.Cells(7).value
    Else
        MsgBox "No match found"
    End If
    seq = seq + 1
    num = num + 1
Loop Until num = TableNo + 1


'' Now, create all ActiveX CY labels and populate with CY
num = 3
seq = 1
Do
    Set ils = ActiveDocument.Tables(num).cell(7, 2).Range.InlineShapes.AddOLEControl(ClassType:="Forms.Label.1")
    Set ctl = ils.OLEFormat.Object
    ctl.Name = "CY" & seq
    If Not IsError(m) Then
    Set rw = rng.Rows(m)
    ctl.Caption = rw.Cells(6).value
    Else
        MsgBox "No match found"
    End If
    seq = seq + 1
    num = num + 1
Loop Until num = TableNo + 1


Set exWB = Nothing

End Sub

下面链接到我之前的问题： 使用 Excel 数据在 VBA 中创建 Word Doc 标题标签

Answer 1

这个：

For Each rngrow In rng.Range("A1:L144")

将被解释为

For Each rngrow In rng.Range("A1:L144").Cells

所以你的循环将是 A1, B1, C1, ... L1 然后是 A2, B2 等等。

好像你的意思是：

For Each rngrow In rng.Range("A1:L144").Rows

所以rngRow将是 A1:L1，然后是 A2:L2，等等。

编辑- 您不能使用类似MsgBox(active.Range ("A2"))东西来引用active ，因为它是一个多区域范围。

试试这个，例如 -

For Each rw in active.Rows
    debug.print "Row:" & rw.Row, rw.cells(8).value
Next rw

EDIT2 ：试试这个。 未经测试，但我认为它应该可以正常工作

Private Sub CommandButton1_Click()

    Dim objExcel As Excel.Application
    Dim exWB As Excel.Workbook
    Dim data, r As Long, resRow As Long, seq As Long, num As Long
    Dim doc As Document

    'get the Excel data as a 2D array
    Set objExcel = New Excel.Application
    Set exWB = objExcel.Workbooks.Open("O:\Documents\Database.csv")
    data = exWB.Sheets("Sheet1").Range("A1:L144").Value '>> 2D array
    exWB.Close False
    objExcel.Quit

    resRow = 0
    'find the first matching row, if any
    For r = 1 To UBound(data, 1)
        If (data(r, 8) = "Active" Or data(r, 8) = "Merged") And _
                              data(r, 3) = doc.Code1.Caption Then
            resRow = r        'this is the row we want
            Exit Sub          'done looking
        End If
    Next r

    Set doc = ActiveDocument
    seq = 1
    For num = 3 To doc.Tables.Count
        With doc.Tables(num)
            AddLabel .Cell(6, 2), "FY" & seq, IIf(resRow > 0, data(resRow, 7), "Not found")
            AddLabel .Cell(7, 2), "CY" & seq, IIf(resRow > 0, data(resRow, 6), "Not found")
        End With
        seq = seq + 1
    Next num

End Sub

'add a label to a cell, set its name and caption
Sub AddLabel(theCell As Cell, theName As String, theCaption As String)
    Dim ils As InlineShape, ctl As MSForms.Label
    Set ils = theCell.Range.InlineShapes.AddOLEControl(ClassType:="Forms.Label.1")
    Set ctl = ils.OLEFormat.Object
    ctl.Name = theName
    ctl.Caption = theCaption
End Sub