我想知道是否有人可以帮助我解决以下问题。 我有两个 excel 工作簿。 工作簿 A 包含从 1 到 1000 的帐单数据。 每张账单按数字顺序位于不同的行上。 工作簿 B 包含账单发起人信息。 但是,它的格式为每行 1 个发起人,因此 1 个账单可以占用多行。 此外,账单编号在 A 列中,而发起人名称在 B 列中。 因此,您必须根据 A 列中的值从 B 列中选择名称。
我想从工作簿 B 中为每个法案选择每个发起人的名称,并将其粘贴到每个法案的工作簿 A 中。 我可以手动完成,但这需要很长时间。 有没有办法自动化它? 提前谢谢你。
数据如下所示
工作簿 A
列 A
1阿拉伯数字
3
四5
工作簿 B
列 A 列 B
列1 名称 ID
1 名称 ID
2 名称编号
2 名称编号
2 名称编号
2 名称编号
一个可能的解决方案是使用用户定义的公式,当用作数组公式时,将为每个账单 ID 返回一个以逗号分隔的账单发起人列表。 我之前在这里发布了 UDF 的代码。 在VBA模块中输入代码后,在工作簿A的B2中输入以下公式:
=CCARRAY(IF(A2=[Workbook_B]Sheet_Name!$A$2:$A$2000,[Book2]Sheet_Name!$B$2:$B$2000),", ")
按 Ctrl+Shift+Enter 将公式作为数组公式输入。然后填写所有账单 ID。
为了清楚起见,您需要插入适当的文件和工作表名称,并调整行数以匹配您的数据。 此外,由于数组公式在计算上可能有点笨拙,因此您可能需要复制 B 列并将特殊的"仅值"粘贴回 B 列。
未经测试...
Sub Tester()
Dim Bills As Excel.Worksheet
Dim Sponsors As Excel.Worksheet
Dim c As Range, f As Range
Set Bills = Workbooks("WorkbookA").Sheets("Bills")
Set Sponsors = Workbooks("WorkbookB").Sheets("Sponsors")
Set c = Sponsors.Range("A2")
Do While c.Value <> ""
Set f = Bills.Range("A:A").Find(c.Value, , xlValues, xlWhole)
If Not f Is Nothing Then
Bills.Cells(f.Row, Bills.Columns.Count).End(xlToLeft).Offset(0, 1).Value = c.Offset(0, 1).Value
Else
c.Font.Color = vbRed
End If
Set c = c.Offset(1, 0)
Loop
End Sub
这是一个可以解决问题的宏。
它在内存变体阵列中完成工作以提供合理的速度。循环遍历单元格/行将生成更简单的代码,但运行速度会慢得多。
它要求(和测试)所有账单ID都存在于发起人列表中
此外,它使用 , 来分隔发起人列表,因此 不得出现在任何发起人名称中。 如果是选择其他字符.
Sub GetSponsors()
Dim rngSponsors As Range, rngBills As Range
Dim vSrc As Variant
Dim vDst() As Variant
Dim i As Long, j As Long
' Assumes data starts at cell A2 and extends down with no empty cells
Set rngSponsors = Sheets("Sponsors").[A2]
Set rngSponsors = Range(rngSponsors, rngSponsors.End(xlDown))
' Count unique values in column A
j = Application.Evaluate("SUM(IF(FREQUENCY(" _
& rngSponsors.Address & "," & rngSponsors.Address & ")>0,1))")
ReDim vDst(1 To j, 1 To 2)
j = 1
' Get original data into an array
vSrc = rngSponsors.Resize(, 2)
' Create new array, one row for each unique value in column A
vDst(1, 1) = vSrc(1, 1)
vDst(1, 2) = "'" & vSrc(1, 2)
For i = 2 To UBound(vSrc, 1)
If vSrc(i - 1, 1) = vSrc(i, 1) Then
vDst(j, 2) = vDst(j, 2) & "," & vSrc(i, 2)
Else
j = j + 1
vDst(j, 1) = vSrc(i, 1)
vDst(j, 2) = "'" & vSrc(i, 2)
End If
Next
Set rngBills = Sheets("Bills").[A2]
Set rngBills = Range(rngBills, rngBills.End(xlDown))
' check if either list has missing Bill numbers
If UBound(vDst, 1) = rngBills.Rows.Count Then
' Put new data in sheet
rngBills.Resize(, 2) = vDst
rngBills.Columns(2).TextToColumns , _
Destination:=rngBills.Cells(1, 2), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, _
Semicolon:=False, _
Comma:=True, _
Space:=False, _
Other:=False
ElseIf UBound(vDst, 1) < rngBills.Rows.Count Then
MsgBox "Missing Bills in Sponsors list"
Else
MsgBox "Missing Bills in Bills list"
End If
End Sub