Selecting Cells Based on Criteria, then Copy and Paste Special (Transpose) - Macro Help

I was wondering if anyone could help me with the following problem. I have two excel workbooks. Workbook A contains bill data running from 1 to 100开发者_如何学运维0. Each bill is on a different line in numerical order. Workbook B contains bill sponsor information. However, it is formatted as 1 sponsor per line, so 1 bill can occupy multiple rows. Also, the bill number is in column A, while the sponsor name is in column B. So, you have to select the names from column B based on the values from column A.

I would like to select the names of each sponsor for each bill from workbook B and paste special (transpose) them into workbook A for each bill. I can do this by hand, but it will take a very long time. Is there anyway to automate it? Thank you in advance.

The data look like this

Workbook A

Column A

1

2

3

4

5

Workbook B

Column A Column B

1 Name ID

1 Name ID

2 Name ID

2 Name ID

2 Name ID

2 Name ID

A possible solution is to use a user-defined formula, that when used as array formula, will return a comma-separated list of bill sponsors for each bill id. I posted the code for the UDF previously here. Once you have entered the code in a VBA module, enter the following formula in B2 in Workbook A:

=CCARRAY(IF(A2=[Workbook_B]Sheet_Name!$A$2:$A$2000,[Book2]Sheet_Name!$B$2:$B$2000),", ")

Press Ctrl+Shift+Enter to enter the formula as an array formula. Then fill-down for all Bill IDs.

Just to be clear, you'll need to insert the appropriate file and sheet names and adjust the number of rows to match your data. Also, since array formulas can be kind of computationally clunky, you'll probably want to copy column B and paste special 'Values only' back to column B.

Untested...

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

Here's a macro that will do the trick.

It does the work in memory variant arrays to provide resonable speed. Looping over the cells/rows would produce simpler code, but would run much slower.

It requires (and tests for) that all the BillIDs are present in the sponsor list

Also, it uses , to seperate the sponsors list, so , must not be in any of the sponsor names. If it is choose a different character .

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