匹配数据子集

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

链接到下面的我的上一个问题： Using Excel data to create Word Doc caption labels in VBA

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，依此类推。

编辑-您无法使用active之类的字词来引用MsgBox(active.Range ("A2"))，因为它是一个多区域范围。

例如尝试-

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