Question

我想知道是否有人可以帮我解决以下问题。我有两本excel工作簿。工作簿A包含从1到1000运行的帐单数据。每个帐单按数字顺序位于不同的行上。工作簿B包含账单赞助商信息。但是，每行格式化为1个赞助商，因此1个帐单可以占用多行。此外，帐单编号位于A列，而赞助商名称位于B列。因此，您必须根据A列中的值从B列中选择名称。

我想从工作簿B中为每个帐单选择每个赞助商的名称，并将其特别（转置）粘贴到每个帐单的工作簿A中。我可以手工完成，但需要很长时间。反正有自动化吗？提前谢谢。

数据看起来像这样

练习册A
A栏 1
2
3
4
5

练习册B
A栏B栏 1名称ID
1名称ID
2名称ID
2名称ID
2名称ID
2名称ID

Answer 1

一种可能的解决方案是使用用户定义的公式，当用作数组公式时，将为每个账单ID返回以逗号分隔的账单赞助商列表。我之前发布了UDF的代码here。在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列。

Answer 2

未经测试...

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

Answer 3

这是一个可以解决问题的宏。

它在内存变量数组中工作以提供合理的速度。循环遍历单元格/行将产生更简单的代码，但运行速度会慢得多。

它要求（并测试）所有BillID都出现在赞助商名单中

此外，它使用，分隔赞助商名单，因此，不得在任何赞助商名称。如果是选择不同的角色

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

根据条件选择单元格，然后复制并粘贴特殊（转置） - 宏帮助

3 个答案: