Matching subset of data

问题

I am populating ActiveX control labels with a subset of Excel data in VBA. My code previously worked for the entire Excel workbook, but once I changed my code to only reference a subset of the data, the incorrect data is being entered.

Here is a snapshot of example data. In my code, Column 6= CY and Column 7 = FY. The code is currently populating my labels with the headers of Column 6 and 7 rather than the values of 'active' or 'merged' projects.

As mentioned, I am not receiving any error messages, but the correct data is not being added to my ActiveX labels. FYI... In line 31 Code1 is the name of an ActiveX label.

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

Link to my previous question below: Using Excel data to create Word Doc caption labels in VBA

回答1:

This:

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

will be interpreted as

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

so your loop will be A1, B1, C1, ... L1 then A2, B2 etc.

It seems like you meant it to be:

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

so rngRow will be A1:L1, then A2:L2, etc.

EDIT - You can't refer to active using something like MsgBox(active.Range ("A2")), since it's a multi-area range.

Try this for example -

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

EDIT2: try this instead. Untested but I think it should work OK

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

来源：https://stackoverflow.com/questions/60306637/matching-subset-of-data

标签

excel

vba

ms-word

activex