匹配数据子集

问题描述

我正在用VBA中的Excel数据子集填充ActiveX控件标签.我的代码以前可以在整个Excel工作簿中使用，但是一旦我更改代码以仅引用数据的子集，就输入了错误的数据.

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.

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

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.

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

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

链接到下面的我的上一个问题:使用Excel数据在以下位置创建Word Doc标题标签VBA

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

推荐答案

此:

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

将被解释为

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

所以您的循环将是A1，B1，C1，... L1，然后是A2，B2等.

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

似乎您是故意这样的:

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

所以rngRow将是A1:L1，然后是A2:L2，依此类推.

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

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

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

例如尝试-

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

EDIT2 :尝试使用此方法.未经测试，但我认为应该可以

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

这篇关于匹配数据子集的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持！