excel - 匹配数据子集
问题描述
我正在用 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
解决方案
这个:
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
推荐阅读
- python-3.x - 无法在数据框中将 Dtype 'O' 更改为 str
- android-studio - 无法构建 android 应用程序 - EPERM: operation not allowed 错误
- php - 为什么 dns_get_record 不适用于某些域?
- java - 如何在java中引用模块
- python - 尝试关闭窗口的Python中的权限被拒绝错误
- codeigniter - 为什么不能将数据从summernote保存到Codeigniter中的DB MySQL
- flutter - Flutter 在升级后启动应用程序时抛出 Invalid arguments(s) 错误
- r - 计算外积矩阵二次形式的有效方法
- python - 绘图窗口在关闭后一直打开
- python - Pandas:将特定功能应用于列并在新数据框中创建列